Excel VBA - Find and copy non-matching rows to another worksheet

Question

I would like to compare 2 columns in the same worksheet, search for non-matching values in column A when compared to column D and copy the entire rows of these non-matching values in column A to another worksheet.

Here is a sample of the worksheet:

Therefore, I would like to compare column A with column D, find the values which do not match and copy the entire corresponding rows from Columns A and B to a new worksheet.

*Edit, I forgot to include my code

Dim CopyToRow As Integer
Dim rng1 As Range
Dim rng2 As Range
Dim cell As Range
Dim found As Range

'Start copying data to row 2 in Sheet2 (row counter variable)
CopyToRow = 2

Set rng1 = Range(ActiveSheet.Cells(2, 1), ActiveSheet.Cells(2, 1).End(xlDown))
Set rng2 = Range(ActiveSheet.Cells(4, 2), ActiveSheet.Cells(4, 2).End(xlDown))

For Each cell In rng1

Set found = rng2.Find(what:=cell, LookIn:=xlValues, lookat:=xlWhole, MatchCase:=False)

If Not found Is Nothing Then

cell.EntireRow.Copy Destination:=Sheets("Sheet2").Range("A" & CopyToRow)

CopyToRow = CopyToRow + 1

End If

Next cell

Many thanks and much appreciated!

Answer 1

I agree with Ron Rosenfeld that you should have demonstrated your own attempt. That being said, perhaps this will be of some help to you. Not the most elegant but should work provided you update references to your own sheet names.

Sub SOPractice()
    
    Dim SearchCell As Range 'each value being checked
    Dim SearchRng As Range 'column A
    Dim LastRow As Long
    Dim MatchFound As Range
    Dim i As Long: i = 1
    
    LastRow = YourSheet.Range("A" & Rows.Count).End(xlUp).Row
    
    With YourSheet
        Set SearchRng = .Range(.Cells(2, 1), .Cells(LastRow, 1))
    
    
    Application.ScreenUpdating = False
    
    For Each SearchCell In SearchRng
        Set MatchFound = .Range("D:D").Find _
        (What:=SearchCell.Value, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
        
        If MatchFound Is Nothing Then 'No match hence copy to other sheet
            .Range(SearchCell.Address, SearchCell.Offset(, 1)).Copy
            YourCopyToSheet.Cells(i, 1).PasteSpecial xlPasteAll
            i = i + 1
        End If
    
    Next SearchCell
    
    End With

    Application.ScreenUpdating = True
    Application.CutCopyMode = False
        
End Sub

Answer 2

I have also found a solution, using a Dictionary object:

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

Set Dic = CreateObject("scripting.dictionary")

With Dic
For Each Cl In MyWorksheet1Name.Range("D2", MyWorksheet1Name.Range("D" & Rows.Count).End(xlUp))
    .Item(Cl.Value) = Empty
Next Cl
For Each Cl In MyWorksheet1Name.Range("A2", MyWorksheet1Name.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 MyWorksheet2Name.Range("A" & Rows.Count).End(xlUp)
End If

Cheers!