Comparing each rows in column1 with column2 and highlight the difference and populate the difference in another sheets

Question

i am new to VBA, i got a task to compare two columns.macro should compares the entries on each column in the active worksheet with respect to the other column and highlights the differences. It also adds the different values to another sheet for both columns. i have created the code with the help of google & youtube and its working fine. but the issue is if we feed input around 30000+ rows, macro took more time to complete the task. Is there any way to reduce the timing. i have pasted the code below. please check and suggest.

'Looping into the columns'

     For r = 2 To LastRow
         Row2inCol1 = Cells(r, Column1.Column).Value
         Row2inCol2 = Cells(r, Column2.Column).Value

    'Searching 1st row of column1 with column2

    If Row2inCol1 <> "" Then
        Set inCol2 = Column2.Find(Row2inCol1)
            If inCol2 Is Nothing Then
                Cells(r, Column1.Column).Interior.ColorIndex = 31
                'Adding highlighted results in different sheet
                Col1Diff = Col1Diff + 1
                Sheets("Results").Cells(Col1Diff + 1, 1).Value = Row2inCol1
            End If
    End If


    'Searching "2nd row of column2 with column1
    
    If Row2inCol2 <> "" Then
        Set inCol1 = Column1.Find(Row2inCol2)
            If inCol1 Is Nothing Then
                Cells(r, Column2.Column).Interior.ColorIndex = 31
                'Adding highlighted results in different sheet
                Col2Diff = Col2Diff + 1
                Sheets("Results").Cells(Col2Diff + 1, 2).Value = Row2inCol2
            End If
    End If
Next r

Answer 1

• Utilize Dictionary objects to obtain a unique list and find the difference.
• Enhance efficiency by loading data into an array.

Microsoft documentation:

Dictionary object

Application.Union method (Excel)

Range.End property (Excel)

Option Explicit

Sub CompareTwoCols()
    Dim oSht1 As Worksheet, oSht2 As Worksheet, LastRow As Long
    Dim arrData1, arrData2
    Const COL1 = "A"  ' modify as needed
    Const COL2 = "B"
    Set oSht1 = Sheets("Sheet1")  ' modify as needed
    Set oSht2 = Sheets("Results")
    ' Load data into array
    With oSht1
        LastRow = .Cells(.Rows.Count, COL1).End(xlUp).Row
        arrData1 = .Cells(1, COL1).Resize(LastRow).Value
        LastRow = .Cells(.Rows.Count, COL2).End(xlUp).Row
        arrData2 = .Cells(1, COL2).Resize(LastRow).Value
    End With
    ' COL1 vs COL2
    CompareCol oSht1, COL1, arrData1, arrData2, oSht2.Range("A1")
    ' COL2 vs COL1
    CompareCol oSht1, COL2, arrData2, arrData1, oSht2.Range("B1")
End Sub

Sub CompareCol(oSht1 As Worksheet, baseCol, arrA, arrB, rTargetCell As Range)
    Dim i As Long, rDiff As Range
    Dim objDic2 As Object, sKey As String, objDicRes As Object
    Set objDic2 = CreateObject("scripting.dictionary")
    Set objDicRes = CreateObject("scripting.dictionary")
    With oSht1
        ' Load data into Dict
        For i = LBound(arrB) + 1 To UBound(arrB)
            arrB(i, 1) = CStr(arrB(i, 1))
            objDic2(arrB(i, 1)) = ""
        Next i
        ' Loop through data on baseCol
        For i = LBound(arrA) + 1 To UBound(arrA)
            sKey = CStr(arrA(i, 1))
            If Not objDic2.exists(sKey) Then
                ' Get the different item (unique list)
                objDicRes(sKey) = ""
                ' Get the cell refer
                If rDiff Is Nothing Then
                    Set rDiff = .Cells(i, baseCol)
                Else
                    Set rDiff = Application.Union(rDiff, .Cells(i, baseCol))
                End If
            End If
        Next i
        ' Highlight cell(s)
        If Not rDiff Is Nothing Then
            .Columns(baseCol).Interior.Color = xlNone
            rDiff.Interior.ColorIndex = 31
        End If
        ' Write ouput to sheet
        rTargetCell.EntireColumn.ClearContents
        rTargetCell.Resize(objDicRes.Count, 1) = Application.Transpose(objDicRes.keys)
    End With
End Sub