Compare two sheets and highlight unmatched rows using unique ID only

Question

I want to match rows from two different sheets and highlight only in the first column of the unmatched row or better still copy the unmatched rows into a new sheet. The code should compare the rows of the two Sheets and color the new rows in the second sheet. Sheet2 (say Jan 2020) contains more rows than Sheet1 (Dec 2019) as its the recently updated sheet and they both contain rows of over 22k with both having unique ID as the first column.

My below code tries to highlight all the unmatching cells and takes longer time to finish. What I wish is for the code to just color the unmatched in column A (the vb.Red) only(since its the unique ID) while ignoring the rest of the column/cells (vb.Yellow) and or if possible copy the highlighted rows into a new sheet.

Sub RunCompare()
Call compareSheets("Sheet1", "Sheet2") 'compareSheets("2019-01 Database", "2019-02 Database")
End Sub


Sub compareSheets(shtSheet1 As String, shtSheet2 As String)
Dim c As Integer, j As Integer, i As Integer, mydiffs As Integer, cnt1 As Integer, cnt2 As Integer
Dim noexist As Integer
cnt2 = Worksheets("Sheet2").Cells.SpecialCells(xlCellTypeLastCell).Row
cnt1 = Worksheets("Sheet1").Cells.SpecialCells(xlCellTypeLastCell).Row
'For each cell in sheet2 that is not the same in Sheet1, color it yellow
For i = 1 To cnt2
    For j = 1 To cnt1
        If ActiveWorkbook.Worksheets(shtSheet2).Cells(i, 1).Value = ActiveWorkbook.Worksheets(shtSheet1).Cells(j, 1).Value Then
            For c = 2 To 22
                If Not ActiveWorkbook.Worksheets(shtSheet2).Cells(i, c).Value = ActiveWorkbook.Worksheets(shtSheet1).Cells(j, c).Value Then
                    ActiveWorkbook.Worksheets(shtSheet2).Cells(i, c).Interior.Color = vbYellow
                    mydiffs = mydiffs + 1
                End If
            Next
        Exit For
        End If
        If j = cnt1 Then
            ActiveWorkbook.Worksheets(shtSheet2).Cells(i, 1).Interior.Color = vbRed
        End If
    Next
Next
'Display a message box to demonstrate the differences and if there is a new entry on the second sheet
'MsgBox mydiffs & ":differences found, " & noexist & ":no exist", vbInformation
ActiveWorkbook.Sheets(shtSheet2).Select
End Sub

Answer 1

Let's simplify the task and do it step by step.

• This is how the input in the two sheets can look like:

Then, we may consider reading these and saving them to an array:

---

Set rangeA = ThisWorkbook.Worksheets(1).Range("A1:Z1")
Set rangeB = ThisWorkbook.Worksheets(2).Range("A1:ZZ1")

Dim arrayA As Variant
Dim arrayB As Variant

With Application
    arrayA = .Transpose(.Transpose(rangeA))
    arrayB = .Transpose(.Transpose(rangeB))
End With

• Looping between the data in the two arrays is quite fast in vba. The writing to the third worksheet is done only once the two values from the two arrays match:

---

Dim myValA As Variant
Dim myValB As Variant
Dim currentRow As Long: currentRow = 1

For Each myValA In arrayA
    For Each myValB In arrayB
        If myValA = myValB Then
            ThisWorkbook.Worksheets(3).Cells(currentRow, 1) = myValA
            currentRow = currentRow + 1
        End If
    Next
Next

This is the result in the third worksheet, all matching values are in a single row:

This is how the whole code looks like:

Sub CompareTwoRanges()

    Dim rangeA As Range
    Dim rangeB As Range

    Set rangeA = ThisWorkbook.Worksheets(1).Range("A1:Z1")
    Set rangeB = ThisWorkbook.Worksheets(2).Range("A1:ZZ1")

    Dim arrayA As Variant
    Dim arrayB As Variant

    With Application
        arrayA = .Transpose(.Transpose(rangeA))
        arrayB = .Transpose(.Transpose(rangeB))
    End With

    Dim myValA As Variant
    Dim myValB As Variant
    Dim currentRow As Long: currentRow = 1

    For Each myValA In arrayA
        For Each myValB In arrayB
            If myValA = myValB Then
                ThisWorkbook.Worksheets(3).Cells(currentRow, 1) = myValA
                currentRow = currentRow + 1
            End If
        Next
    Next

End Sub

Note - there will be another performance bonus, if the results are written to an array and then written from the array to the worksheet. Thus the writing would happen only once. This is the change, that needs to be implemented in the code, after the array declarations:

Dim myValA As Variant
Dim myValB As Variant
Dim resultArray() As Variant
ReDim Preserve resultArray(2 ^ 20)
Dim i As Long: i = 0

For Each myValA In arrayA
    For Each myValB In arrayB
        If myValA = myValB Then
            resultArray(i) = myValA
            i = i + 1
        End If
    Next
Next

ReDim Preserve resultArray(i)
ThisWorkbook.Worksheets(3).Cells(1, 1).Resize(UBound(resultArray)) = Application.Transpose(resultArray)

Answer 2

when you get cell value, it spends time.

so, you can target Range transfer 2d Variant

Dim endRow AS Long
Dim olderRange AS Range
Dim olderVariant AS Variant
endRow = olderSheet.cells(rows.count,1).end(xlup).row
Set olderRange = olderSheet.Range(olderSheet.Cells(startRow, startCol), olderSheet.Cells(endRow, endCol))

'Transfer
olderVariant = olderRange 

For currentRow = 1 to UBound(olderVariant, 1)
   'Loop
   'if you want change real Cell value Or interior
   'add row Or Col weight
   if olderVariant(currentRow, currentCol) = newerVariant(currentRow, currentCol) THen
      newerSheet.Cells(currentRow+10,currentCol+10).interior.colorIndex = 3
   End if
Next currentRow

Answer 3

In case anyone has the same kind of problem, I have found an easier way to do it. Providing your sheet2 is the comparison sheet:

Dim Ary1 As Variant, Ary2 As Variant
Dim r As Long

Ary1 = Sheets("Sheet1").UsedRange.Value2
Ary2 = Sheets("Sheet2").UsedRange.Value2
With CreateObject("scripting.dictionary")
   For r = 1 To UBound(Ary1)
      .Item(Ary1(r, 1)) = Empty
   Next r
   For r = 1 To UBound(Ary2)
      If Not .Exists(Ary2(r, 1)) Then Sheets("Sheet2").Cells(r, 1).Interior.Color = vbRed
   Next r
End With