Find and copy non-matching cells to another worksheet

I would like to compare cells in Worksheet 2 against Worksheet 1.

First check for matching cells in range A for both Worksheets 1 and 2.

Next, if there are no matches, check for matching cells in range B for both Worksheets 1 and 2, otherwise check the next cell in range A.

If there are no matches as well, copy these non-matching cells in ranges A and B in Worksheet 2 to a new worksheet, Worksheet 3.


Here are my worksheets' layout:

Worksheet 1 -

1.png

Worksheet 2 -

2.png

Worksheet 3 -

3.png


From the screenshot of Worksheet 2, only the rows highlighted in yellow should be copied to Worksheet 3 since its values in both range A and B cannot be found in Worksheet 1's corresponding range A and B.


Here is my code so far, but it's only checking range A for both Worksheets 1 and 2:

```
Dim Cl As Range, Rng As Range, Dic As Object

Set Dic = CreateObject("scripting.dictionary")

With Dic
For Each Cl In wsk1.Range("A2", wsk1.Range("A" & Rows.Count).End(xlUp))
.Item(Cl.Value) = Empty
Next Cl
For Each Cl In wsk2.Range("A2", wsk2.Range("A" & Rows.Count).End(xlUp))
If Not .Exists(Cl.Value) Then
If Rng Is Nothing Then Set Rng = Cl Else Set Rng = Union(Rng, Cl)
End If
Next Cl
End With

If Not Rng Is Nothing Then
Rng.EntireRow.Copy wsk3.Range("A" & Rows.Count).End(xlUp)
End If
```

Many thanks!

Hi TropicalMagic,

Try this:

Option Explicit
Sub Macro1()

    Dim lngMyRow As Long, lngLastRow As Long, lngPasteRow As Long, i As Long
    Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
    
    Application.ScreenUpdating = False
    
    Set ws1 = ThisWorkbook.Sheets("Sheet1")
    Set ws2 = ThisWorkbook.Sheets("Sheet2")
    Set ws3 = ThisWorkbook.Sheets("Sheet3")
    
    lngLastRow = ws2.Range("A:B").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    
    For lngMyRow = 2 To lngLastRow
        If Application.WorksheetFunction.CountIf(ws1.Range("A:A"), CStr(ws2.Range("A" & lngMyRow))) = 0 Then
            If Application.WorksheetFunction.CountIf(ws1.Range("B:B"), CStr(ws2.Range("B" & lngMyRow))) = 0 Then
                On Error Resume Next 'Surpress error message if there's no data in 'ws3'
                    lngPasteRow = ws3.Range("A:B").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
                On Error GoTo 0
                lngPasteRow = IIf(lngPasteRow = 0, 2, lngPasteRow + 1)
                ws2.Range("A" & lngMyRow & ":B" & lngMyRow).Copy Destination:=ws3.Range("A" & lngPasteRow)
                i = i + 1
            End If
        End If
    Next lngMyRow
    
    Application.ScreenUpdating = True
    
    If i = 0 Then
        MsgBox "There were no unmatched records found in """ & ws2.Name & """ when compared to """ & ws1.Name & """.", vbInformation
    Else
        MsgBox "The " & Format(i, "#,##0") & " non matching records from """ & ws2.Name & """ compared to """ & ws1.Name & """ have now been copied to """ & ws3.Name & """.", vbInformation
    End If

End Sub

Regards,

Robert

You're welcome and thank you for marking thread as solved and the rep