比较两列 A 和 B 以获取 3 列 C、D 和 E 中的数据

Question

我正在寻找一个 VBA 来比较两列 A 和 B 以获取 3 列 C、D 和 E 中的数据。

• C 应该具有在 A 列中但不在 B 列中的值。
• D 应该具有在 B 列中但不在 A 列中的值。
• E 应具有 A 列和 B 列中的值。

A栏	B栏	C栏	D栏	E 列
1	4	5	4	1
2	1			2
3	2			3
5	3

这是我目前想要增强的代码。

Sub Compare1() 'Excel VBA to compare 2 lists.
    Dim ar as Variant
    Dim var()
    Dim i As Long
    Dim n As Long
    
    ar = Range("a1").CurrentRegion 'Change Input to suit
    ReDim var(1 To UBound(ar, 1), 1 To 1)
    
    With Createobject("scripting.dictionary")
        .comparemode = 1

        For i = 1 To UBound(ar, 1)
            .Item(ar(i, 2)) = Empty
        Next

        For i = 1 To UBound(ar, 1)
            If Not .exists(ar(i, 1)) Then
                n = n + 1
                var(n, 1) = ar(i, 1)
            End If
        Next
    End With

    [D1].Resize(n).Value = var 'Change output to suit  
End Sub

Answer 1

请参阅下面的解决方案并解释代码中的注释。

它使用Application.Match如果找不到值则返回错误。 我们可以使用它来确定另一列中是否存在值。 如果是这样，它们都在两者中，否则它们对于该列是唯一的。 然后我们只需要将它们推送到所需的输出列。

整个计算使用数组完成，以加快处理速度。 然后将数组写入单元。

Option Explicit

Public Sub Compare()
    Dim ws As Worksheet  ' define worksheet
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    
    Const HeaderColumns As Long = 1  ' define how many header columns there are
    
    ' get last used rows in column A and B
    Dim LastRowA As Long
    LastRowA = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    
    Dim LastRowB As Long
    LastRowB = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row
    
    ' read column A and B into arrays
    Dim InputDataA() As Variant
    InputDataA = ws.Range("A1").Resize(LastRowA, 1).Value2
    
    Dim InputDataB() As Variant
    InputDataB = ws.Range("B1").Resize(LastRowB, 1).Value2
    
    ' Define output ranges
    Dim OutRngOnlyInA As Range
    Set OutRngOnlyInA = ws.Range("C1").Resize(LastRowA, 1)
    
    Dim OutRngOnlyInB As Range
    Set OutRngOnlyInB = ws.Range("D1").Resize(LastRowB, 1)
    
    Dim OutRngInBoth As Range
    Set OutRngInBoth = ws.Range("E1").Resize(Application.Min(LastRowA, LastRowB), 1)
    
    ' get output ranges into arrays
    Dim OutOnlyInA() As Variant
    OutOnlyInA = OutRngOnlyInA.Value2
    
    Dim OutOnlyInB() As Variant
    OutOnlyInB = OutRngOnlyInB.Value2
    
    Dim OutInBoth() As Variant
    OutInBoth = OutRngInBoth.Value2
    
    ' define counters for output arrays
    Dim cntOnlyInA As Long, cntOnlyInB As Long, cntInBoth As Long
    cntOnlyInA = HeaderColumns
    cntOnlyInB = HeaderColumns
    cntInBoth = HeaderColumns
    
    ' loop through input data
    Dim iRow As Long
    For iRow = 1 + HeaderColumns To Application.Max(UBound(InputDataA), UBound(InputDataB))
        If iRow <= UBound(InputDataA) Then
            If IsError(Application.Match(InputDataA(iRow, 1), InputDataB, 0)) Then
                ' cannot be found in B so it is only A
                cntOnlyInA = cntOnlyInA + 1
                OutOnlyInA(cntOnlyInA, 1) = InputDataA(iRow, 1)
            Else
                ' can be found in B so it is in A and B
                cntInBoth = cntInBoth + 1
                OutInBoth(cntInBoth, 1) = InputDataA(iRow, 1)
            End If
        End If
        
        If iRow <= UBound(InputDataB) Then
            If IsError(Application.Match(InputDataB(iRow, 1), InputDataA, 0)) Then
                ' cannot be found in A so it is only B
                cntOnlyInB = cntOnlyInB + 1
                OutOnlyInB(cntOnlyInB, 1) = InputDataB(iRow, 1)
            End If
        End If
    Next iRow

    ' write output to cells
    OutRngOnlyInA.Value2 = OutOnlyInA
    OutRngOnlyInB.Value2 = OutOnlyInB
    OutRngInBoth.Value2 = OutInBoth
End Sub