VBA编程解决工作的事情，找重复次数，脱敏

最近做一个execl表，内容是查找相同信息（F列）的客户，就是把一个客户的信息，例如手机号码，或者家庭地址，跟别的客户对比，发现一样的话，把名字记录下来，如此下去，最终发现几个客户的名字（H列）并在一个格里面（I列），方便咨询单个客户跟其他人员（姓名）的关系。
涉及的客户名字可能自己跟自己重复出现，要分辨。

Sub test()
    Dim title As String 
    'Set titleRange = Application.InputBox(prompt:="请选择拆分的表头，必须是第一行，且为一个单元格，如：“姓名”", Type:=8)
    'cells(x,9) 就是I列 x行的内容
    '用F列的一格，跟F列的全部内容对比，如果发现相同的，就合并H列的内容。赋值给对应行的 I列
    ic = Cells(Rows.Count, 1).End(3).Row
    
    For i = 1 To ic
        title = Cells(i, 8)
        For j = 1 To ic
           If Cells(j, 6) = Cells(i, 6) And title <> Cells(j, 8) Then
                If InStr(1, title, Cells(j, 8)) = 0 Then
                  title = Cells(j, 8) + "," + title
                End If
                             
           End If
        Next j
     
            Cells(i, 9) = title     
    Next i
End Sub

处理考勤事项的代码

Sub 按钮4_Click()

Dim date2 As Date

endcount = Cells(Rows.Count, 1).End(3).Row

For i = 2 To endcount
    date2 = Cells(i, 2)
    date3 = Cells(i + 1, 2)
    '周六日判断 2就是周一，6就是周五
    days = Weekday(date2)
    If (days > 1 And days < 7) Then
        h = Hour(date2)
        If (h < 12 And h > 8) Then
            Cells(i, 3) = "迟到"
        ElseIf (h = 8) Then
        
            m = Minute(date2)
            If (m > 30) Then
                Cells(i, 3) = "迟到"
            
            End If
       End If
       If (h < 17 And h > 12) Then
            Cells(i, 3) = "早退"

 
        End If
        
        
        '周六日判断外
        Else
            Cells(i, 3) = "周六日"
    End If
    If (Hour(date2) < Hour(date3)) Then
    Cells(i, 4) = Format$(date2, "hh:mm") + "-" + Format$(date3, "hh:mm")
    
    End If
    
Next

End Sub

批量导入文件夹里面的excel文件 .xlsx结尾

Function vbaTest(filedir As String, starti As Integer, dataExcel As Object)
    '数据读取
'----------------------------------------------
    Dim Workbook, sheet
    Dim totalRow As Integer
    Dim sheetC As Integer
       
    Set Workbook = dataExcel.Workbooks.Open(filedir)
    sheetCount = Workbook.Worksheets.count

    'For ii = 1 To sheetCount
    For Each isheet In Workbook.Sheets

        Set sheet = isheet  'Workbook.Worksheets(ii) '读取第一个sheet页的数据,扩展其他sheet

        'totalRow = ActiveSheet.Range("C" & Rows.Count).End(xlUp).Row
        'totalRow = 100
        sheetC = sheetC + 1
        'totalRow = sheet.UsedRange.Rows.count
        totalRow = sheet.Cells(Rows.count, 2).End(xlUp).Row
        totalColumn = sheet.UsedRange.Columns.count
        For i = 1 To totalRow
            For j = 1 To totalColumn
                Sheets(1).Cells(i + starti, j) = sheet.Cells(i, j)
            Next j
        Next i
        starti = starti + totalRow

    Next
    Workbook.Close
    vbaTest = starti
    
'----------------------------------------------
End Function
Sub OpenAndClose()
    Dim MyFile As String
    Dim MyFiledir As String
    Dim ddir As String
    Dim s As String
    Dim count, starti As Integer
    Dim dataExcel As Object
    
    '新建一个对话框对象
    Set FolderDialogObject = Application.FileDialog(msoFileDialogFolderPicker)
    
    '配置对话框
    With FolderDialogObject
        .Title = "请选择要查找的文件夹"
        .InitialFileName = ThisWorkbook.Path
    End With
    
    '显示对话框
    FolderDialogObject.Show
    
    '获取选择对话框选择的文件夹
    Set paths = FolderDialogObject.SelectedItems
    
    If paths.count = 0 Then
        MsgBox "未选中任何文件夹，退出"
        Exit Sub
    End If
    
    Set dataExcel = CreateObject("Excel.Application")
    ddir = paths(1) + "\"

    MyFile = Dir(ddir + "*.xls")
    '读入文件夹中的第一个.xlsx文件
    count = count + 1       '记录文件的个数
    s = s & count & "" & MyFile
    MyFiledir = ddir + MyFile
    starti = 1
    starti = vbaTest(MyFiledir, starti, dataExcel)
    
    Do While MyFile <> ""
        MyFile = Dir        '第二次读入的时候不用写参数
        If MyFile = "" Then
            Exit Do         '当MyFile为空的时候就说明已经遍历完了，这时退出Do，否则还要运行一遍
        End If
        count = count + 1
        MyFiledir = ddir + MyFile
        starti = vbaTest(MyFiledir, starti, dataExcel)
        If count Mod 2 <> 1 Then
            s = s & vbTab & count & "" & MyFile
        Else
            s = s & vbCrLf & count & "" & MyFile
       End If
    Loop
    Debug.Print s
End Sub

找出一列出现重复的次数超过3，但是不是同一个人

Sub f()
'先对要处理的列进行排序，然后使用函数
'0 和空值 为缺失不算入重复
Dim Count As Integer '重复次数
Dim str As String  '名字数组
Count = 1
cha_lie = "r" '查询重复的列，J列 联系地址 排序后 M手机号码 N电话号码
endcount = Cells(Rows.Count, 1).End(3).Row
For i = 1 To endcount
str = Cells(i, "D") 'T列存放姓名组，C列是姓名
    For j = i + 1 To i + 4
        If Cells(j, cha_lie) = "" Or Cells(j, cha_lie) = "0" Then
           str = "缺失"
    
        ElseIf (Cells(i, cha_lie) = Cells(j, cha_lie)) And InStr(str, Cells(j, "D")) = 0 Then
            Count = Count + 1
            str = str + " | " + Cells(j, "D")
        End If
    Next
If (Count > 2) Then
Cells(1, "W") = Cells(1, cha_lie) + "的重复次数"
Cells(i, "W") = Count
Cells(1, "x") = Cells(1, cha_lie) + "的重复名字组"
Cells(i, "X") = str
End If
Count = 1
Next

End Sub

脱敏操作。

Sub tuomin_f()

Dim biaotoun As Integer
'表头行号，默认是第一行，有时候会第二行。看实际
'客户代码资金账户等数字类型的最好先文本格式。
biaotoun = 1
Dim dis As String
dis = "1客户代码证件号码手机号码联系地址客户姓名资金账号联系方式住所|柜台留存的移动电话|受益所有人身份证件号码|客户回访或核实的电话号码|受益所有人联系地址|客户名称执照名称执照号码身份证号码负责人身份证件号码法定代表人姓名控股股东或实际控制人姓名控股股东或实际控制人身份证件号码|法定代表人身份证件号码|授权业务办理人身份证件号码|授权业务办理人姓名|受益所有人姓名"

dis2 = "1身份证件有效期限法定代表人身份证件有效期限控股股东或实际控制人身份证件有效期限授权业务办理人身份证件有效期限受益所有人身份证件有效期限建立业务关系时间重新识别开展时间持续识别开展时间"


Dim tempstr As String
tempstr = CStr(biaotoun) + ":" + CStr(biaotoun)
sheetCount = Worksheets.Count '表数量

For ii = 1 To sheetCount
Worksheets(ii).Activate
'endcol = Application.CountA(ActiveSheet.Range(tempstr))
endcol   = Cells(1, Columns.Count).End(1).Column
endcount = Cells(Rows.Count, biaotoun).End(3).Row
For heng = 1 To endcol
    Data1 = Cells(biaotoun, heng)
    Data1 = Replace(Data1, Chr(10), vbNullString)
    '删除换行符 chr(10)
    If (InStr(biaotoun, dis, Data1)) Then
    
    For i = biaotoun + 1 To endcount
    Cells(i, heng).Select
    Selection.NumberFormatLocal = "@"
    len1 = Len(Cells(i, heng))
    Data = Cells(i, heng)
    If (len1 > 6) Then
    Cells(i, heng) = Mid(Data, 1, CInt(len1 / 2)) + "**" + Mid(Data, len1, 1)
    Else
    Cells(i, heng) = Mid(Data, 1, CInt(len1 / 2)) + "*"
    End If
    
    Next
    '-----------------------------字典2的处理-------------------------------------
    ElseIf (InStr(biaotoun, dis2, Data1)) Then
    For i = biaotoun + 1 To endcount
    Data = Cells(i, heng)
    '设置单元格 文本格式
    Cells(i, heng).Select
    Selection.NumberFormatLocal = "@"
    If Data < 21000000 Then
     Cells(i, heng) = Mid(Data, 3, 6)
    Else
     Cells(i, heng) = 999999
    End If
    
    Next
    
    End If

Next
Next
End Sub

统计一定时间内开发的客户数，每周新增数量，使用字典数据格式，然后关系表显示。

Sub f()
'统计一定时间内的开发客户数

Dim dic As Object
Set dic = CreateObject("Scripting.Dictionary") '引用字典

 nowdate = 20200419

I = 2
Do While Cells(I, "f") <> ""
    key1 = Cells(I, "i").Value
    If CStr([key1]) = "Error 2042" Then
        key1 = "表外客户"
    End If
    
    If dic.Exists(key1) Then
        dic.Item(key1) = dic.Item(key1) + 1 '写入键和键值，要注意写入的方法
        If Cells(I, 6) > nowdate Then
            dic.Item("本周" + key1) = dic.Item("本周" + key1) + 1
        End If
    Else
        dic.Item(key1) = 1
        If Cells(I, 6) > nowdate Then
            dic.Item("本周" + key1) = 1
        Else
            dic.Item("本周" + key1) = 0
        End If
    End If
    I = I + 1
Loop
'遍历dic ，分三列显示 key value 本周.value
falg = 1
For Each Ikey In dic.keys()

   If (falg = 1) Then
      Cells(I + 1, 1) = Ikey
      Cells(I + 1, 2) = dic(Ikey)
       falg = 0
    Else
       falg = 1
        Cells(I + 1, 3) = dic(Ikey)
        I = I + 1
    End If
    
Next


End Sub

Sub f()
'统计一定时间内的开发客户数

Dim dic As Object
Set dic = CreateObject("Scripting.Dictionary") '引用字典


 nowdate = 20200419

I = 2
Do While Cells(I, "A") <> ""
    name1 = Cells(I, "A").Value
    If CStr([name1]) = "Error 2042" Then
        key1 = "问题"
    End If
    'Split(
    date1 = Split(Cells(I, "B"), " ")
    If dic.Exists((name1 + date1(0))) Then
        dic.Item(name1 + date1(0) + "w") = date1(1) '写入键和键值，要注意写入的方法
    Else
        dic.Item(name1 + date1(0)) = date1(1)
    End If
    I = I + 1
Loop
'遍历dic ，分三列显示 key value 本周.value
falg = 1
For Each Ikey In dic.keys()
   If (falg = Ikey) Then
        Cells(I, 3) = dic(Ikey)      
    Else
        Cells(I + 1, 1) = Ikey
        Cells(I + 1, 2) = dic(Ikey)
        falg = Ikey + "w"
        I = I + 1
    End If
Next
End Sub

自查开户信息是否正常，每年11月处理。

Sub 自查开户信息()
'身份证相关处理 1、身份证号长度，2、身份证发证机关，3、身份证地址，4、身份证有效期，5、身份证有效期间隔
Dim var_str As String
endcount = Cells(Rows.Count, 1).End(3).Row
For i = 2 To endcount
    var_str = Cells(i, 5)
    '处理身份证相关
    If (var_str = "身份证") Then
        If Len(Cells(i, "F")) <> 18 Then
            msg = msg + "身份证位数不足18.|"
        End If
        
        jiange = Cells(i, "H") - Cells(i, "G")
        If (jiange = 50000 Or jiange = 100000 Or jiange = 200000 Or jiange > 200000) Then
            msg = msg + ""
        Else
           msg = msg + "身份证间隔异常.间隔是 " + Str(jiange) + "|"
        End If
        dqrq = Replace(Cells(i, "W"), "-", "")
        jiange2 = 20211220 - dqrq
        If jiange2 > 0 Then
            msg = msg + "到期日超6个月 " + Str(jiange2) + "|"       
        End If
    End If
        
        
    End If
    
    '处理地址，身份证发证机关
    If Len(Cells(i, "J")) < 6 Then msg = msg + "地址太短了" + Str(Len(Cells(i, "J"))) + "|"
    
    If InStr(Cells(i, "J"), "？") > 0 Then msg = msg + "地址里面有奇怪字符。" + "|"
    If InStr(Cells(i, "J"), "！") > 0 Then msg = msg + "地址里面有奇怪字符。" + "|"
    If InStr(Cells(i, "J"), "：") > 0 Then msg = msg + "地址里面有奇怪字符。" + "|"
    
    If InStr(Cells(i, "K"), "公局") > 0 Then msg = msg + "发证机关有错字。" + "|"
    If InStr(Cells(i, "K"), "分安") > 0 Then msg = msg + "发证机关有错字。" + "|"
    '手机号码长度
    If Len(Cells(i, "O")) <> 11 Then msg = msg + "手机号码不等于11位" + Str(Len(Cells(i, "J"))) + "|"
    If msg = "" Then
        Cells(i, "U") = "暂无问题"
    Else
        Cells(i, "U") = msg
        Debug.Print msg 'sngMulti(intI, intJ)
        msg = ""
    End If
Next
    
End Sub