【原创】AB列数据对比找差异、相同工具

约定的童话

刚才逛论坛发现好几个帖子关于对比两列数据找差异的，所以就做了一个AB列对比找差异和相同项的小工具，分享一下，有需自取！大佬就忽视吧，代码开源，采用VBA字典实现，注重效率！

最怕认真

谢谢分享！学习中

angelgreat

太厉害了，感谢

everbest2015

应该没有必要定义j 这个变量   第一次 for循环结束了以后   第二次循环 依然可以用for i    没必要在内存里再开辟一个j的变量地址

yunfei2018

A/B共有，也可以这样：

1. Sub AB共有2()
   
2.     Dim arr, d As Object, i As Long, m As Long, ZR()
   
3.     arr = [a1].CurrentRegion
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     For i = 2 To UBound(arr)
   
6.         d(arr(i, 1)) = ""
   
7.     Next i
   
8.     ReDim ZR(1 To UBound(arr), 1 To 1)
   
9.     m = 0
   
10.     For i = 2 To UBound(arr)
    
11.         If d.exists(arr(i, 2)) Then
    
12.             m = m + 1
    
13.             ZR(m, 1) = arr(i, 2)
    
14.         End If
    
15.     Next i
    
16.     [F2].Resize(m, 1) = ZR
    
17.     Set d = Nothing
    
18. End Sub

复制代码

约定的童话

yunfei2018 发表于 2019-6-25 16:04
A/B共有，也可以这样：

做进去，文件传上来，署名备注下

yunfei2018

约定的童话 发表于 2019-6-25 16:09
做进去，文件传上来，署名备注下

公司档案加密，上传不了附件，把代码上传吧，
其实差不多的，也是利用字典的共性。

1. Sub A独有2()
   
2.     Dim arr, d As Object, i As Long, m As Long, ZR()
   
3.     arr = Range("B2:B" & Range("b65536").End(3).Row)
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     For i = 1 To UBound(arr)
   
6.         d(arr(i, 1)) = ""
   
7.     Next i
   
8.     arr = Range("A2:A" & Range("A65536").End(3).Row)
   
9.     ReDim ZR(1 To UBound(arr), 1 To 1)
   
10.     m = 0
    
11.     For i = 1 To UBound(arr)
    
12.         If Not d.exists(arr(i, 1)) Then
    
13.             m = m + 1
    
14.             ZR(m, 1) = arr(i, 1)
    
15.         End If
    
16.     Next i
    
17.     [D2].Resize(m, 1) = ZR
    
18.     Set d = Nothing
    
19. End Sub
    
20. 
    
21. Sub B独有2()
    
22.     Dim arr, d As Object, i As Long, m As Long, ZR()
    
23.     arr = Range("A2:A" & Range("A65536").End(3).Row)
    
24.     Set d = CreateObject("scripting.dictionary")
    
25.     For i = 1 To UBound(arr)
    
26.         d(arr(i, 1)) = ""
    
27.     Next i
    
28.     arr = Range("B2:B" & Range("B65536").End(3).Row)
    
29.     ReDim ZR(1 To UBound(arr), 1 To 1)
    
30.     m = 0
    
31.     For i = 1 To UBound(arr)
    
32.         If Not d.exists(arr(i, 1)) Then
    
33.             m = m + 1
    
34.             ZR(m, 1) = arr(i, 1)
    
35.         End If
    
36.     Next i
    
37.     [E2].Resize(m, 1) = ZR
    
38.     Set d = Nothing
    
39. End Sub
    
40. 
    
41. Sub AB共有2()
    
42.     Dim arr, d As Object, i As Long, m As Long, ZR()
    
43.     arr = [a1].CurrentRegion
    
44.     Set d = CreateObject("scripting.dictionary")
    
45.     For i = 2 To UBound(arr)
    
46.         d(arr(i, 1)) = ""
    
47.     Next i
    
48.     ReDim ZR(1 To UBound(arr), 1 To 1)
    
49.     m = 0
    
50.     For i = 2 To UBound(arr)
    
51.         If d.exists(arr(i, 2)) Then
    
52.             m = m + 1
    
53.             ZR(m, 1) = arr(i, 2)
    
54.         End If
    
55.     Next i
    
56.     [F2].Resize(m, 1) = ZR
    
57.     Set d = Nothing
    
58. End Sub
    
59. 
    

复制代码

liujw_35

谢谢楼主！

a704019026

yunfei2018 发表于 2019-6-25 16:14
公司档案加密，上传不了附件，把代码上传吧，
其实差不多的，也是利用字典的共性。

比葫芦画瓢  弄个函数 哈哈
Public Function A独有(A, B) 'A中有B中没有的内容。A,B只能是列不能是行。且结果不去除A中的重复值，若需去除重复值，可配合unique函数使用
    Dim arr, BRR, d As Object, i As Long, m As Long, ZR()
    arr = B
    Set d = CreateObject("scripting.dictionary")
    For i = 1 To UBound(arr)
        d(arr(i, 1)) = ""
    Next i
    BRR = A
    ReDim ZR(1 To UBound(BRR), 1 To 1)
    m = 0
    For i = 1 To UBound(BRR)
        If Not d.exists(BRR(i, 1)) Then
            m = m + 1
            ZR(m, 1) = BRR(i, 1)
        End If
    Next i

    A独有 = 非空(ZR)
    Set d = Nothing
End Function
Public Function AB共有(A, B) 'A中AB中都有的值。可配合unique函数去重，求得AB交集
    Dim arr, BRR, d As Object, i As Long, m As Long, ZR()
    arr = B
    BRR = A
    Set d = CreateObject("scripting.dictionary")
    For i = 2 To UBound(arr)
        d(arr(i, 1)) = ""
    Next i
    ReDim ZR(1 To UBound(BRR), 1 To 1)
    m = 0
    For i = 2 To UBound(BRR)
        If d.exists(BRR(i, 1)) Then
            m = m + 1
            ZR(m, 1) = BRR(i, 1)
        End If
    Next i
    AB共有 = 非空(ZR)
    Set d = Nothing
End Function
Public Function 非空(A)
Dim arr, k As Long, BRR, l As Long, n As Long
arr = A
For k = UBound(arr) To 1 Step -1
  If arr(k, 1) <> "" Then
   l = k
  ReDim BRR(1 To l, 1 To 1)
      For n = 1 To l
      If arr(n, 1) <> "" Then
        BRR(n, 1) = arr(n, 1)
      Else: BRR(n, 1) = " "
      End If
       Next n
          非空 = BRR
   Exit For

End If
Next k
End Function

cui26896

好象和这个是一样的
https://blog.csdn.net/djy_623047237/article/details/78579858