比较 2 个工作表，将唯一的行导出到另一个工作表

Question

我将提供两个联系人列表作为 CSV。清单 2 是一个新的出口。清单 1 是一周前的。但是，列表 2包括列表 1 中的联系人。

这不是“删除重复项”的问题，因为我只想提取唯一行。

我在 Sheet1 中有列表 1。我在 Sheet2 中有列表 2。 Sheet3 为空。我需要将列表 1 中的第 3 列（电子邮件地址）与列表 2 中的第 3 列（电子邮件地址）和 EntireRow.Copy 进行比较，其中第 3 列是唯一的，即它只出现在列表 2 中，而不出现在列表 1 中。

我对条件逻辑并不陌生，但我从未像这样使用过 Excel 宏/VBA。我能够find a solution（请参阅“第二个代码”）将重复项导出到新工作表，并尝试对其进行修改以导出唯一性，但我无法使其工作。

编辑 1 这是我根据上述答案修改的代码。

Option Explicit

Sub FilterAndCopy2()

Dim wstSource As Worksheet, _
    wstOutput As Worksheet
Dim rngMyData As Range, _
    helperRng As Range, _
    unionRng As Range
Dim i As Long, iOld As Long

Set wstSource = Worksheets("DUPLICATE LIST FILTER")
Set wstOutput = Worksheets("UNIQUE LIST RESULTS")

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
With wstSource
    Set rngMyData = .Range("A1:K" & .Range("A" & .Rows.Count).End(xlUp).Row)
End With

With rngMyData
    Set helperRng = .Offset(, rngMyData.Columns.Count - 1).Resize(, 1)
    Set unionRng = .Cells(1000, 1000) 'set a "helper" cell to be used with Union method, to prevent it from failing the first time
End With

With helperRng
    .FormulaR1C1 = "=row()" 'mark rows with ad ascending number (its own row number)
    .Value = .Value
End With

With rngMyData.Resize(, rngMyData.Columns.Count + 1) 'enclose "helper" column
    .Sort key1:=.Columns(10), Order1:=xlAscending, Orientation:=xlTopToBottom, Header:=xlNo ' sort data to have all same columnA values grouped one after another
    i = .Rows(1).Row 'start loop from data first row
    Do While i < .Rows(.Rows.Count).Row
        iOld = i 'set current row as starting row
        Do While .Cells(iOld + 1, 1) = .Cells(iOld, 1) 'loop till first cell with different value
            iOld = iOld + 1
        Loop

        If iOld - i = 0 Then Set unionRng = Union(unionRng, .Cells(i, 1).Resize(iOld - i + 1)) 'if more than one cell found with "current" value, then add them to "UnionRng" range
        i = iOld + 1
    Loop
    Intersect(unionRng, rngMyData).EntireRow.Copy Destination:=wstOutput.Cells(1, 1) 'get rid of the "helper" cell via Intersect method
    wstOutput.Columns(helperRng.Column).Clear 'delete "Helper" column pasted in wstOutput sheet
    .Sort key1:=.Columns(10), Order1:=xlAscending, Orientation:=xlTopToBottom, Header:=xlNo ' sort data in wstSource back
End With
helperRng.Clear 'delete "helper" column, not needed anymore

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

End Sub

结果未比较 电子邮件 列。我在我的数据中发现了一个已知重复项，并修改了电子邮件地址。该行未导出到目标工作表。

注意：这个正在进行中的解决方案不使用我上面描述的 3 个单独的工作表，只有两个。

Answer 1

下面的代码假设您不需要实际复制/粘贴行，而是在结果表中传输值。

Sub find_unique()
Application.ScreenUpdating = False

Dim Wb As Workbook, Sh1 As Worksheet, Sh2 As Worksheet, Sh3 As Worksheet
Dim P1 As Range, P2 As Range, a As Integer

Set Wb = Workbooks("unique.xlsm")
Set Sh1 = Wb.Sheets(1) ' Adapt to original list
Set Sh2 = Wb.Sheets(2) ' Adapt to updated list
Set Sh3 = Wb.Sheets(3) ' Adapt to destination sheet
Set P1 = Sh1.UsedRange
Set P2 = Sh2.UsedRange
Set D1 = CreateObject("scripting.dictionary")

T1 = P1

For i = 2 To UBound(T1)
    D1(UCase(T1(i, 1))) = UCase(T1(i, 1)) 'Change 1 for the column number of your unique identifier
Next i

T2 = P2
a = 1
Dim T3()

For i = 1 To UBound(T2)
    If i = 1 Then 'Considering you have headers
        ReDim Preserve T3(1 To UBound(T2, 2), 1 To a)
        For j = 1 To UBound(T2, 2)
            T3(j, a) = T2(i, j)
        Next j
        a = a + 1
    Else
        If Not D1.exists(UCase(T2(i, 1))) Then 'Change 1 for the column number of you unique identifier
            ReDim Preserve T3(1 To UBound(T2, 2), 1 To a)
            For j = 1 To UBound(T2, 2)
                T3(j, a) = T2(i, j)
            Next j
            a = a + 1
        End If
    End If
Next i

Sh3.Cells.Clear 'Assuming you want to replace the result in sheet(3) each time
Sh3.Range("A1").Resize(UBound(T3, 2), UBound(T3, 1)) = Application.Transpose(T3)

Application.ScreenUpdating = True
End Sub

如果您真的想复制/粘贴唯一行，其他选项：

Sub find_unique2()
Application.ScreenUpdating = False

Dim Wb As Workbook, Sh1 As Worksheet, Sh2 As Worksheet, Sh3 As Worksheet
Dim P1 As Range, P2 As Range, a As Integer

Set Wb = Workbooks("unique.xlsm")
Set Sh1 = Wb.Sheets(1) ' Adapt to original list
Set Sh2 = Wb.Sheets(2) ' Adapt to updated list
Set Sh3 = Wb.Sheets(3) ' Adapt to destination sheet
Set P1 = Sh1.UsedRange
Set P2 = Sh2.UsedRange
Set D1 = CreateObject("scripting.dictionary")

T1 = P1

For i = 2 To UBound(T1)
    D1(UCase(T1(i, 1))) = UCase(T1(i, 1)) 'Change 1 for the column number of your unique identifier
Next i

T2 = P2
a = 2
Sh3.Cells.Clear

For i = 1 To UBound(T2)
    If i = 1 Then 'Considering you have headers
        Sh2.Rows(1).Copy Sh3.Rows(1)
    Else
        If Not D1.exists(UCase(T2(i, 1))) Then 'Change 1 for the column number of you unique identifier
            Sh2.Rows(i).Copy Sh3.Rows(a)
            a = a + 1
        End If
    End If
Next i

Application.ScreenUpdating = True
End Sub