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

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

CodePudding user response：

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.