Compare 2 Sheets, Export Unique Rows to Another Sheet - vba

Question

I am being providing two contact lists as CSVs. List 2 is a new export. List 1 is from a week prior. However, List 2 includes the contacts from List 1.
This is not a matter of "Remove Duplicates" because I want to extract only the unique rows.
I have List 1 in Sheet1. I have List 2 in Sheet2. Sheet3 is empty. I need to compare Column 3 (email address) in List 1 to Column 3 (email address) in List 2 and EntireRow.Copy where Column 3 is unique, i.e. it appears ONLY in List 2, NOT in List 1.
I am no stranger to conditional logic, but I've never used Excel Macros / VBA like this. I was able to find a solution (see "2nd code") to export duplicates to a new sheet, and tried to modify it to export uniques, but I wasn't able to make it work.
EDIT 1
This is the code I modified from the aforementioned answer.
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
The result is not comparing the Email column. I found a known duplicate in my data, and modified the email address. The row was not exported to the target Sheet.
NOTE: This in-progress solution does not use 3 separate sheets as I described above, only two.

Answer 1

Code below is assuming you don't need to actually copy/paste the row but rather transfer the value in the result sheet.
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
Other option if you really want to copy/paste the unique row :
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