找出两列相同项与不相同项及两列共有 Option Explicit
Sub 对比两列()
Dim LastA, LastB, arrA, arrB
Dim x&, y&, k&, arr1(1 To 100, 1 To 1), arr2(1 To 100, 1 To 1), arr3(1 To 100, 1 To 1)
Dim s&, m%, a&, b&, c&, n&, dic1, dic2, dic3, x1, x2&, x3&
Set dic1 = CreateObject("Scripting.dictionary")
Set dic2 = CreateObject("Scripting.dictionary")
Set dic3 = CreateObject("Scripting.dictionary")
Application.ScreenUpdating = False
LastA = Sheets("两列数据对比").Cells(Rows.Count, 1).End(xlUp).Row
LastB = Sheets("两列数据对比").Cells(Rows.Count, 2).End(xlUp).Row
arrA = Range("A1:A" & LastA)
arrB = Range("B1:B" & LastB)
For x = 1 To UBound(arrA, 1)
For y = 1 To UBound(arrB, 1)
If arrB(y, 1) = arrA(x, 1) Then
k = k + 1
s = s + 1
arr1(k, 1) = arrA(x, 1) '把A列在B列有的装入数组arr1,共有的
Exit For
End If
Next y
If s = 0 Then
m = m + 1
arr2(m, 1) = arrA(x, 1) '把A列有的，B没有的装入数组arr2里
End If
s = 0 '为什么要归零，为了下一次判断
Next x
For b = 1 To UBound(arrB, 1)
For a = 1 To UBound(arrA, 1)
If arrA(a, 1) = arrB(b, 1) Then
c = c + 1
Exit For
End If
Next a
If c = 0 Then
n = n + 1
arr3(n, 1) = arrB(b, 1) '把B列有的，A列没有装进数组arr3
End If
c = 0 '为什么要归零，为了下一次判断
Next b
For x1 = 1 To UBound(arr1, 1)
If arr1(x1, 1) <> "" Then
dic1(arr1(x1, 1)) = "" '字典dic1有去重作用, 把A列里重复的去掉
End If
Next x1
For x2 = 1 To UBound(arr2, 1)
If arr2(x2, 1) <> "" Then
dic2(arr2(x2, 1)) = "" '字典dic2有去重作用, 把A列里重复的去掉
End If
Next x2
For x3 = 1 To UBound(arr3, 1)
If arr3(x3, 1) <> "" Then
dic3(arr3(x3, 1)) = "" '字典dic3有去重作用, 把B列里重复的去掉
End If
Next x3
On Error Resume Next
Application.DisplayAlerts = False
Sheets("两列对比后的结果").Delete
Application.DisplayAlerts = True
On Error GoTo 0
Sheets.Add after:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = "两列对比后的结果"
With Sheets("两列对比后的结果")
.[A1] = "在A列有B列没有"
.[B1] = "在B列有A列没有"
.[C1] = "A列和B列都有的"
.[A2].Resize(dic2.Count, 1) = Application.WorksheetFunction.Transpose(dic2.keys)
.[B2].Resize(dic3.Count, 1) = Application.WorksheetFunction.Transpose(dic3.keys)
.[C2].Resize(dic1.Count, 1) = Application.WorksheetFunction.Transpose(dic1.keys)
.Columns("A:C").EntireColumn.AutoFit
End With
Application.ScreenUpdating = True
End Sub
|
