求A列身份证号的重复清单

ykcbf1100

     A列身份证号，有小部分是重复的，现求助列出身份证号重复的清单。叩谢！我前面试了下，用公式法好象不行，身份证号有18位，用公式的话，感觉结果有错。
附件如下：

smiletwo

Sub ss()
  Dim i, j, R, arr, dic As Object
  Set dic = CreateObject("scripting.dictionary")
  With Sheet1
     R = .Cells(Rows.Count, 1).End(3).Row
     arr = .Range("A2:D" & R)
     For i = 1 To UBound(arr)
        If Not dic.Exists(arr(i, 1)) Then
           dic(arr(i, 1)) = " "
        Else
           arr(i, 3) = arr(i, 1)
        End If
     Next i
     For i = 1 To UBound(arr)
        If Not dic.Exists(arr(i, 2)) Then
           arr(i, 4) = arr(i, 2)
        End If
     Next i
     .Range("A2:D" & R) = arr
  End With
End Sub

sheeboard

用pandas参考

1. import pandas as pd
   
2. df=pd.read_excel('求A列中身份证号重复的清单.xlsm',dtype={'身份证号':'str','身份证号2':'str'})
   
3. duplicated=df[df['身份证号'].duplicated()]
   
4. notInA=df[~df['身份证号2'].isin(df['身份证号'])]
   

复制代码

ykcbf1100

smiletwo 发表于 2021-9-13 12:31
Sub ss()
  Dim i, j, R, arr, dic As Object
  Set dic = CreateObject("scripting.dictionary")

按你的代码运行后，C列和D列没有数据。你再帮看一下啊。

smiletwo

ykcbf1100 发表于 2021-9-13 14:13
按你的代码运行后，C列和D列没有数据。你再帮看一下啊。

D列无数据，这是C列数据：

ykcbf1100

smiletwo 发表于 2021-9-14 11:23
D列无数据，这是C列数据：

好的，谢谢了。

ykcbf1100

三年前的求助，自己回头解一遍。

ykcbf1100

自己的求助自己解。

1. Sub ykcbf()  '//2024.6.13
   
2.     Set d = CreateObject("Scripting.Dictionary")
   
3.     r = Cells(Rows.Count, 1).End(3).Row
   
4.     ReDim brr(1 To r, 1 To 1)
   
5.     For i = 2 To r
   
6.         s = CStr(Cells(i, 1))
   
7.         d(s) = d(s) + 1
   
8.     Next
   
9.     For Each k In d.keys
   
10.         If d(k) > 1 Then
    
11.             m = m + 1
    
12.             brr(m, 1) = CStr(k)
    
13.         End If
    
14.     Next
    
15.     Columns("c:d").NumberFormatLocal = "@"
    
16.     [c2].Resize(m, 1) = brr
    
17.     r = Cells(Rows.Count, 2).End(3).Row
    
18.     m = 0
    
19.     ReDim brr(1 To r, 1 To 1)
    
20.     For i = 2 To r
    
21.         s = CStr(Cells(i, 2))
    
22.         If d.exists(s) Then
    
23.             m = m + 1
    
24.             brr(m, 1) = s
    
25.         End If
    
26.     Next
    
27.     [d2].Resize(m, 1) = brr
    
28. End Sub
    

复制代码

Qs18

试一下...........

Qs18

Sub test()
With Sheet1
.Range("c2:d10000").ClearContents
Dim arr: arr = .Range("a1:a" & .Cells(Rows.Count, 1).End(xlUp).Row)
ReDim ar(1 To UBound(arr), 1 To 1)
Dim brr: brr = .Range("b1:b" & .Cells(Rows.Count, 2).End(xlUp).Row)
ReDim br(1 To UBound(arr), 1 To 1)
Dim dic: Set dic = CreateObject("scripting.dictionary")
For i = 2 To UBound(arr)
    a = arr(i, 1)
    If Not dic.exists(a) Then
        dic(a) = 1
    Else
        m = m + 1
        ar(m, 1) = "'" & a
    End If
Next
.Range("c2").Resize(m, 1) = ar
dic.RemoveAll
For j = 2 To UBound(brr)
    b = brr(j, 1)
    If Not dic.exists(b) Then dic(b) = 1
Next
For i = 2 To UBound(arr)
      a = arr(i, 1)
    If dic(a) <> 1 Then
        n = n + 1
        br(n, 1) = "'" & a
    End If
Next
.Range("d2").Resize(n, 1) = br
End With
MsgBox "完成"
End Sub