恳请大神们帮忙看下这个重复的标志能否实现

qiongmei6

我想在附件中求得一个代码，如果附件b列的身份证号有重复，那么在对应的f列则标志出重复的数字，这样便于我找出是哪几个是重复的，目前的f列就是我希望得到的结果，再次谢谢各位大神的帮忙

swl4561255

参考代码：

1. Sub test()
   
2. ar = [A1].End(4).Row
   
3. arr = Range("B3:B" & ar)
   
4. Dim brr(1 To 100, 1 To 1)
   
5. For i = 1 To ar - 2
   
6.     n = Application.CountIf(Range("B3:B" & ar), arr(i, 1) & "*")
   
7.     If n > 1 Then
   
8.         brr(i, 1) = "重复" & Right(arr(i, 1), 1)
   
9.     End If
   
10. Next
    
11. [F3].Resize(UBound(brr), 1) = brr
    
12. End Sub
    

复制代码

太极拍天雄

练习一下！！！！！！

liulang0808

供参考。。。。。。。

笨鸟飞不高

寻找社保相邻月份不同的资料.zip (15.28 KB, 下载次数: 5)

2024-4-28 14:11 上传

点击文件名下载附件

ykcbf1100

参与一下。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.4.28
   
2.     Set d = CreateObject("Scripting.Dictionary")
   
3.     r = Cells(Rows.Count, 1).End(3).Row
   
4.     arr = [a1].Resize(r, 6)
   
5.     For i = 3 To UBound(arr)
   
6.         s = arr(i, 1) & arr(i, 2) & arr(i, 3)
   
7.         d(s) = d(s) + 1
   
8.     Next
   
9.     [f3:f1000] = ""
   
10.     For Each k In d.keys
    
11.         If d(k) > 1 Then
    
12.             m = m + 1
    
13.             For i = 3 To UBound(arr)
    
14.                 s = arr(i, 1) & arr(i, 2) & arr(i, 3)
    
15.                 If k = s Then
    
16.                     arr(i, 6) = "重复" & m
    
17.                 End If
    
18.             Next
    
19.         End If
    
20.     Next
    
21.     [a1].Resize(r, 6) = arr
    
22.     Set d = Nothing
    
23.     MsgBox "OK！"
    
24. End Sub
    

复制代码