VBA找出身份证号重复人员遇到的问题

碧水红叶

根据论坛中星光老师提供的代码做了一些修改，在运行过程中还是有一些问题，附件中有详细的说明。麻烦各位老师帮忙解答一下。

Chip_Kenny

try this:

1. Sub dd()
   
2. Dim d As Object, arr, brr, i&, j&, k, r%
   
3. Dim rng As Range, rng1 As Range
   
4. Set rng = Selection
   
5. Set d = CreateObject("scripting.dictionary")
   
6. On Error GoTo ex
   
7.    If Selection.Count = Application.CountBlank(rng) Then
   
8.       Set rng = Application.InputBox("请选择需要处理的数据", "数据范围", Type:=8)
   
9.       GoTo last
   
10.    Else
    
11.       GoTo last
    
12.    End If
    
13. last:
    
14. arr = Range(rng.Address)
    
15. r = rng(1).Row - 1
    
16. For i = 1 To UBound(arr)
    
17.     d(arr(i, 1)) = d(arr(i, 1)) & "," & i + r
    
18. Next
    
19. For i = 1 To UBound(arr)
    
20.     t = Mid(d(arr(i, 1)), 2)
    
21.     If InStr(t, ",") Then arr(i, 1) = "与第" & t & "行重复" Else arr(i, 1) = ""
    
22. Next
    
23. ReDim brr(1 To UBound(arr), 1 To 1)
    
24. Set rng1 = Application.InputBox("请选择验证结果显示区", "显示区域", Type:=8)
    
25. Range(rng1.Address).Resize(UBound(arr), 1) = arr
    
26. Set d = Nothing
    
27. MsgBox "数据验证完成！", vbInformation, "提示"
    
28. Exit Sub
    
29. ex:
    
30. MsgBox "操作已取消，程序退出！", vbInformation, "提示"
    
31. End Sub

复制代码

碧水红叶

Chip_Kenny 发表于 2018-2-7 11:04
try this:

谢谢老师，执行的效果还是比较好的。如果要将显示的结果中不显示当前行号该怎么改代码呢。如上传的图片中所示。

碧水红叶

Chip_Kenny 发表于 2018-2-7 11:04
try this:

如果想要将显示的重复信息添加背景色和字体颜色又该怎么修改代码。老师别嫌烦啊，问题多了一些。

Chip_Kenny

try this:

1. Sub dd()
   
2. Dim d As Object, arr, brr, i&, j&, k, r%
   
3. Dim rng As Range, rng1 As Range
   
4. Dim rg As Object, s$
   
5. Set rg = CreateObject("vbscript.regexp")
   
6. Set rng = Selection
   
7. Set d = CreateObject("scripting.dictionary")
   
8. On Error GoTo ex
   
9.    If Selection.Count = Application.CountBlank(rng) Then
   
10.       Set rng = Application.InputBox("请选择需要处理的数据", "数据范围", Type:=8)
    
11.       GoTo last
    
12.    Else
    
13.       GoTo last
    
14.    End If
    
15. last:
    
16. arr = Range(rng.Address)
    
17. r = rng(1).Row - 1
    
18. For i = 1 To UBound(arr)
    
19.     d(arr(i, 1)) = d(arr(i, 1)) & "," & i + r
    
20. Next
    
21. For i = 1 To UBound(arr)
    
22.     t = Mid(d(arr(i, 1)), 2)
    
23.     If InStr(t, ",") Then
    
24.         rg.Pattern = "\b(" & i + r & ",)|(," & i + r & "\b)"
    
25.         arr(i, 1) = "与第" & rg.Replace(t, "") & "行重复"
    
26.         s = s & "|" & i + r
    
27.     Else: arr(i, 1) = ""
    
28.     End If
    
29. Next
    
30. rng(1)(1, 2).Resize(UBound(arr), 1).Interior.Color = xlNone
    
31. rng(1)(1, 2).Resize(UBound(arr), 1) = arr
    
32. j = rng(1)(1, 2).Column
    
33. brr = Split(s, "|")
    
34. For i = 1 To UBound(brr)
    
35.     Cells(brr(i), j).Interior.Color = 60000
    
36. Next
    
37. Set d = Nothing: Set rg = Nothing
    
38. MsgBox "数据验证完成！", vbInformation, "提示"
    
39. Exit Sub
    
40. ex:
    
41. MsgBox "操作已取消，程序退出！", vbInformation, "提示"
    
42. End Sub

复制代码

HTH