我想把表二和表三做对比，相同不提取，不相同提取出来

limao720605

各位老师帮忙：
  我想把表二和表三做对比，相同不提取，不相同提取出来，，，，使用函数最好

3190496160

Sub 比对()
Dim ar As Variant, cr As Variant
Dim i As Long, r As Long, rs As Long
Dim br()
Dim d As Object, dc As Object
Set d = CreateObject("scripting.dictionary")
Set dc = CreateObject("scripting.dictionary")
With Sheets("sheet2")
    r = .Cells(Rows.Count, 1).End(xlUp).Row
    ar = .Range("a1:b" & r)
End With
With Sheets("sheet3")
    rs = .Cells(Rows.Count, 1).End(xlUp).Row
    cr = .Range("a1:b" & rs)
End With
ReDim br(1 To UBound(ar) + UBound(cr), 1 To UBound(ar, 2))
For i = 2 To UBound(ar)
    zd = ar(i, 1) & "|" & ar(i, 2)
    d(zd) = ""
Next i
For i = 2 To UBound(cr)
    zd = cr(i, 2) & "|" & cr(i, 1)
    dc(zd) = ""
    If Not d.exists(zd) Then
        n = n + 1
        br(n, 1) = cr(i, 2)
        br(n, 2) = cr(i, 1)
    End If
Next i
For i = 2 To UBound(ar)
    zd = ar(i, 1) & "|" & ar(i, 2)
    If Not dc.exists(zd) Then
        n = n + 1
        For j = 1 To UBound(ar, 2)
            br(n, j) = ar(i, j)
        Next j
    End If
Next i
If n = "" Then MsgBox "没有需要提取的数据": End
With Sheets("sheet1")
    .[a1].CurrentRegion.Offset(1) = Empty
    .[a2].Resize(n, UBound(br, 2)) = br
End With
MsgBox "ok!"
End Sub

3190496160

不同提取.rar (19.83 KB, 下载次数: 0)

2024-10-23 09:39 上传

点击文件名下载附件