Highlight multiple unmatched cells in 2 columns from 2 sheets - excel

Question

I have a workbook includes 2 sheets.
In each sheet, it has couple columns like Name(column A), State(column B) and ID (column C). But the rows' sort sequence of two sheets are both random.
According to IDs, I need to use VBA to compare the value of Name and State.
If they don't match, then highlight both of 2 cells in 2 sheets.
The result should be like this:
But my code below can only run for Column A if IDs have the same order sequence.
I understand that it can be much easier if I use conditional formatting to create a new rule or use vlookup or index and match function to compare. But I am asked to use VBA
Thank you!
Sub Test_Sheet()
Dim sheetOne As Worksheet
Dim sheetTwo As Worksheet
Dim lastRow As Long
Dim lastRow2 As Long
Dim thisRow As Long
Dim thisRow2 As Long
Dim lastCol As Long
Dim lastCol2 As Long
Dim thisCol As Long
Dim thisCol2 As Long
Dim foundRow As Range
Dim foundRow2 As Range
Dim lastFoundRow As Long
Dim lastFoundRow2 As Long
Dim searchRange As Range
Dim searchRange2 As Range
Dim isMatch As Boolean
Dim isMatch2 As Boolean
' Set up the sheets
Set sheetOne = Sheets("Sheet1")
Set sheetTwo = Sheets("Sheet2")
' Find the last row of the active sheet
lastRow = sheetOne.Cells(sheetOne.Rows.Count, "A").End(xlUp).Row
lastRow2 = sheetOne.Cells(sheetOne.Rows.Count, "B").End(xlUp).Row
' Set the search range on the other sheet
Set searchRange = sheetTwo.Range("A2:A" & sheetTwo.Cells(sheetTwo.Rows.Count, "A").End(xlUp).Row)
Set searchRange2 = sheetTwo.Range("B2:B" & sheetTwo.Cells(sheetTwo.Rows.Count, "B").End(xlUp).Row)
' Look at all rows
For thisRow = 1 To lastRow
' Find the last column on this row
lastCol = sheetOne.Cells(thisRow, sheetOne.Columns.Count).End(xlToLeft).Column
' Find the first match
Set foundRow = searchRange.Find(sheetOne.Cells(thisRow, "A").Value, searchRange(searchRange.Count), xlValues, xlWhole)
' Must find something to continue
Do While Not foundRow Is Nothing
' Remember the row we found it on
lastFoundRow = foundRow.Row
' Check the found row has the same number of columns
If sheetTwo.Cells(lastFoundRow, sheetTwo.Columns.Count).End(xlToLeft).Column = lastCol Then
' Assume it's a match
isMatch = True
' Look at all the column values
For thisCol = 1 To lastCol
' Compare the column values
If sheetTwo.Cells(lastFoundRow, thisCol).Value <> sheetOne.Cells(thisRow, thisCol).Value Then
' No match
isMatch = False
Exit For
End If
Next thisCol
' If it's still a match then highlight the row
If isMatch Then sheetOne.Range(sheetOne.Cells(thisRow, "A"), sheetOne.Cells(thisRow, lastCol)).Interior.ColorIndex = 3
End If
' Find the next match
Set foundRow = searchRange.Find(sheetOne.Cells(thisRow, "A").Value, foundRow, xlValues, xlWhole)
' Quit out when we wrap around
If foundRow.Row <= lastFoundRow Then Exit Do
Loop
Next thisRow
For thisRow2 = 1 To lastRow2
lastCol2 = sheetOne.Cells(thisRow2, sheetOne.Columns.Count).End(xlToLeft).Column
Set foundRow2 = searchRange2.Find(sheetOne.Cells(thisRow2, "B").Value, searchRange2(searchRange2.Count), xlValues, xlWhole)
Do While Not foundRow2 Is Nothing
lastFoundRow2 = foundRow2.Row
If sheetTwo.Cells(lastFoundRow2, sheetTwo.Columns.Count).End(xlToLeft).Column = lastCol2 Then
isMatch2 = True
For thisCol2 = 1 To lastCol2
If sheetTwo.Cells(lastFoundRow2, thisCol2).Value <> sheetOne.Cells(thisRow2, thisCol2).Value Then
isMatch2 = False
Exit For
End If
Next thisCol2
If isMatch2 Then sheetOne.Range(sheetOne.Cells(thisRow2, "B"), sheetOne.Cells(thisRow2, lastCol2)).Interior.ColorIndex = 5
End If
Set foundRow2 = searchRange2.Find(sheetOne.Cells(thisRow2, "B").Value, foundRow2, xlValues, xlWhole)
If foundRow2.Row <= lastFoundRow2 Then Exit Do
Loop
Next thisRow2
End Sub

Answer 1

Please, try the next code. It uses arrays, for faster iteration, processing the matching in memory and Union ranges, coloring the cells interior at once, at the end. Modifying the interior of each cell consumes Excel resources and takes time:
Sub testCompareIDs()
Dim sheetOne As Worksheet, sheetTwo As Worksheet, lastRow1 As Long, lastRow2 As Long, i As Long, j As Long
Dim rng1 As Range, rng2 As Range, arr1, arr2, rngColA1 As Range, rngColA2 As Range, rngColB1 As Range, rngColB2 As Range
Set sheetOne = Sheets("Sheet1")
Set sheetTwo = Sheets("Sheet2")
lastRow1 = sheetOne.cells(sheetOne.rows.count, "C").End(xlUp).row
lastRow2 = sheetTwo.cells(sheetOne.rows.count, "C").End(xlUp).row
Set rng1 = sheetOne.Range("A2:C" & lastRow1)
Set rng2 = sheetTwo.Range("A2:C" & lastRow2)
arr1 = rng1.value: arr2 = rng2.value 'place ranges to be processed in arrays, for faster iteration
For i = 1 To UBound(arr1)
For j = 1 To UBound(arr2)
If arr1(i, 3) = arr2(j, 3) Then
If arr1(i, 1) <> arr2(j, 1) Then
If rngColA1 Is Nothing Then
Set rngColA1 = rng1.cells(i, 1)
Set rngColA2 = rng2.cells(j, 1)
Else
Set rngColA1 = Union(rngColA1, rng1.cells(i, 1))
Set rngColA2 = Union(rngColA2, rng2.cells(j, 1))
End If
End If
If arr1(i, 2) <> arr2(j, 2) Then
If rngColB1 Is Nothing Then
Set rngColB1 = rng1.cells(i, 2)
Set rngColB2 = rng2.cells(j, 2)
Else
Set rngColB1 = Union(rngColB1, rng1.cells(i, 2))
Set rngColB2 = Union(rngColB2, rng2.cells(j, 2))
End If
End If
Exit For 'exit iteration since the ID has been found
End If
Next j
Next i
If Not rngColA1 Is Nothing Then
rngColA1.Interior.ColorIndex = 3
rngColA2.Interior.ColorIndex = 3
End If
If Not rngColB1 Is Nothing Then
rngColB1.Interior.ColorIndex = 3
rngColB2.Interior.ColorIndex = 3
End If
End Sub
The strings compare is case sensitive. The code can be adapted to not be case sensitive (using Ucase for each compare line)
Please, send some feedback after testing it.