最近做一个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