VBA怎样找出两列数据一列数据相同，另一列不同的数据，并列出表格？

lwz2019

在一个表里有两列数据，分别是姓名和证件号，1.如何用vba快速找出“姓名相同证件号不同的数据”，2.找出“证件号相同姓名不同的数据“；并列表展示如附件，先谢了！

gwjkkkkk

Option Explicit
Sub TEST6()
    Dim ar, br, cr, i&, j&, r&, dic As Object, vKey
   
    Application.ScreenUpdating = False
    Set dic = CreateObject("Scripting.Dictionary")
   
    ar = [A1].CurrentRegion.Value
    ReDim br(1 To UBound(ar), 1 To 2) As String
   
    dic.RemoveAll
    For i = 2 To UBound(ar)
        dic(ar(i, 1)) = dic(ar(i, 1)) & "|" & ar(i, 2)
    Next i
    For Each vKey In dic.keys
        cr = Split(dic(vKey), "|")
        If UBound(cr) > 1 Then
            For i = 1 To UBound(cr)
                r = r + 1
                br(r, 1) = vKey
                br(r, 2) = cr(i)
            Next i
        End If
    Next
    [D1].CurrentRegion.Offset(1).Clear
    [D2].Resize(r, 2) = br
   
    dic.RemoveAll: r = 0
    For i = 2 To UBound(ar)
        dic(ar(i, 2)) = dic(ar(i, 2)) & "|" & ar(i, 1)
    Next i
    For Each vKey In dic.keys
        cr = Split(dic(vKey), "|")
        If UBound(cr) > 1 Then
            For i = 1 To UBound(cr)
                r = r + 1
                br(r, 1) = cr(i)
                br(r, 2) = vKey
            Next i
        End If
    Next
    [G1].CurrentRegion.Offset(1).Clear
    [G2].Resize(r, 2) = br
   
    Set dic = Nothing
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

。。。。。。。。。。

lwz2019

gwjkkkkk 发表于 2024-8-18 16:44
。。。。。。。。。。

首先感谢老师这么快就把代码给写好了，就是结果未达到预期，1.程序会把姓名相同，身份证号同与不同的都列了出来，我想得到的是结果是：只留下姓名相同，证件号不同的展示出来，2.当证件号相同姓名不同的时候，结果也是这个问题！我重新上传一下附件，麻烦您在看看！

lwz2019

附件已更新

gwjkkkkk

lwz2019 发表于 2024-8-18 19:12
附件已更新

.............

悠扬的旋律

lwz2019

gwjkkkkk 发表于 2024-8-18 20:06
.............

结果完美，再次感谢老师！

Qs18

Sub qs()
Dim arr, i, dic
Set dic = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")
With Sheet1
    arr = .Range("a1").CurrentRegion.Value
    ReDim br(1 To UBound(arr), 1 To 2)
    ReDim cr(1 To UBound(arr), 1 To 2)
    For i = 2 To UBound(arr)
       s = arr(i, 1)
       If Not dic.exists(s) Then
        dic(s) = arr(i, 2)
       Else
        If InStr(dic(s), arr(i, 2)) = 0 Then
            dic(s) = dic(s) & "|" & arr(i, 2)
       End If
        End If
        ss = arr(i, 2)
        If Not d2.exists(ss) Then
            d2(ss) = arr(i, 1)
        Else
            If InStr(d2(ss), arr(i, 1)) = 0 Then
                d2(ss) = d2(ss) & "|" & arr(i, 1)
            End If
        End If
    Next
    For Each k In dic.keys
        t = Split(dic(k), "|")
        If UBound(t) > 0 Then
            For x = 0 To UBound(t)
            m = m + 1
            br(m, 1) = k
            br(m, 2) = "'" & t(x)
            Next
        End If
    Next
    For Each kk In d2.keys
        tt = Split(d2(kk), "|")
        If UBound(tt) > 0 Then
            For xx = 0 To UBound(tt)
                mm = mm + 1
                cr(mm, 2) = "'" & kk
                cr(mm, 1) = tt(xx)
            Next
        End If
    Next
.Range("d2").Resize(m, 2) = br
.Range("g2").Resize(mm, 2) = cr
End With
Set dic = Nothing: Set d2 = Nothing
End Sub

Qs18

试试...............