楼主
kevinchengcw |
Q: 如何利用vba代码通过模糊匹配标识重复数据？
A: 问题描述：
实现功能1：C列姓名要求实现，姓名相同或近似相同（前六个字相同）则标注为黄色，认为是重复。
E列身份证号要求实现，号码相同或仅有一位不同则标注为红色，认为是重复。
L列联系电话要求实现，号码相同或仅有一位不同则标注为黄色，认为是重复。
实现功能2：把工作表中，一行中所有单元格没有标注背景的行隐藏，（认为不重复则隐藏）
实现代码及解释如下：- Sub test()
- Dim Rng As Range, R As Range, Dic As Object, Str$, Str2$, Arr, N&
- Set Dic = CreateObject("scripting.dictionary") '创建字典项目
- On Error Resume Next '设置出错继续执行
- Application.ScreenUpdating = False '关闭屏幕刷新
- Rows("2:" & Rows.Count).Interior.ColorIndex = xlNone '清空原有填充色
- For Each Rng In Range("c2:c" & Cells(Rows.Count, "C").End(3).Row) '循环C列有效数据区
- Str = Left(Rng.Value, 6) '提取单元格前6位数据
- If Dic.exists(Str) Then Set Dic(Str) = Union(Rng, Dic(Str)) Else Set Dic(Str) = Rng '如果存在该字典项,则合并当前循环单元格到字典item项,否则添加新字典项目
- Next
- Arr = Dic.keys '提取字典的keys到数组
- For N = LBound(Arr) To UBound(Arr) '循环数组各项
- If Dic(Arr(N)).Cells.Count > 1 Then Dic(Arr(N)).Interior.Color = vbYellow '如果当前循环到的字典key项对应的item项单元格数量大于1,则将对应的单元格底色设置为黄色
- Next N
- With CreateObject("vbscript.regexp") '创建正则项目
- .Global = True '设置全局有效
- For Each Rng In Range("e2:e" & Cells(Rows.Count, "E").End(3).Row) '外层循环循环E列有效数据区
- If Rng <> "" And Rng.Interior.Color <> vbRed Then '如果当前循环到的单元格内容不为空且单元格还未填充颜色,则
- Str = Rng.Value '提取单元格内容
- For N = 1 To Len(Rng.Value) '循环数据文本各项
- Str2 = Left(Rng.Value, N - 1) & ".?" & Right(Rng.Value, Len(Rng.Value) - N) '替换循环到的位置的数据为.?以匹配一个不同或无此字符情况
- Str = Str & "|" & Str2 '串接生成的匹配规则
- Next
- .Pattern = Str '设定匹配规则为设定的字符串
- For Each R In Range("e2:e" & Cells(Rows.Count, "E").End(3).Row) '内层循环循环E列有效数据区
- If R <> "" And Rng.Address <> R.Address And Abs(Len(R.Value) - Len(Rng.Value)) <= 1 Then '如果单元格内容不为空且与外层循环单元格当前循环位置不同且与外层循环到的单元格数据长度差在一个字符以内时,则
- If .test(R.Value) Then '如果当前规则能与内层循环当前循环到的单元格相匹配,则
- Rng.Interior.Color = vbRed '外层循环当前循环到的单元格填充红色
- R.Interior.Color = vbRed '内层循环当前循环到的单元格填充红色
- Exit For '跳出循环
- End If
- End If
- Next R
- End If
- Next Rng
- For Each Rng In Range("l2:l" & Cells(Rows.Count, "l").End(3).Row) 'L列判断模式同上
- If Rng <> "" And Rng.Interior.Color <> vbRed Then
- Str = Rng.Value
- For N = 1 To Len(Rng.Value)
- Str2 = Left(Rng.Value, N - 1) & ".?" & Right(Rng.Value, Len(Rng.Value) - N)
- Str = Str & "|" & Str2
- Next
- .Pattern = Str
- For Each R In Range("l2:l" & Cells(Rows.Count, "l").End(3).Row)
- If R <> "" And Rng.Address <> R.Address And Abs(Len(R.Value) - Len(Rng.Value)) <= 1 Then
- If .test(R.Value) Then
- Rng.Interior.Color = vbYellow
- R.Interior.Color = vbYellow
- Exit For
- End If
- End If
- Next R
- End If
- Next Rng
- End With
- For Each Rng In Intersect(Rows("2:" & Cells(Rows.Count, 3).End(3).Row), ActiveSheet.UsedRange).Rows '循环数据区各行
- N = 0 '以变量作为判定开关,初始为0
- For Each R In Rng.Cells '循环当前循环到的数据区行中的单元格
- If R.Interior.ColorIndex <> xlNone Then '如果有填充颜色则
- N = 1 '变量赋值为1
- Exit For '跳出循环
- End If
- Next R
- If N = 0 Then Rng.EntireRow.Hidden = True '如果变量值为0(即对应行中未发现填充颜色单元格),则对应行隐藏
- Next Rng
- Application.ScreenUpdating = True '打开屏幕刷新
- Set Dic = Nothing '清空字典项目
- End Sub
模糊匹配：以E2单元格为例子
单元格数据：'653101194706270627'
生成的匹配规则：'653101194706270627'|.?653101194706270627'|'.?53101194706270627'|'6.?3101194706270627'|'65.?101194706270627'|'653.?01194706270627'|'6531.?1194706270627'|'65310.?194706270627'|'653101.?94706270627'|'6531011.?4706270627'|'65310119.?706270627'|'653101194.?06270627'|'6531011947.?6270627'|'65310119470.?270627'|'653101194706.?70627'|'6531011947062.?0627'|'65310119470627.?627'|'653101194706270.?27'|'6531011947062706.?7'|'65310119470627062.?'|'653101194706270627.?
如此即可匹配对应位置上的字符不同或不存在的情况
注：本例中因未出现特殊字符，故未有增加转义字符\的情况，其他情况下使用请酌情调整代码
详见附件及素材源帖。
 模糊查重.rar
|
