Excel VBA Code to Compare Rows in Two Different Sheets and Highlight Only the Cells that are different/unique

Walkerwood9

New Member
Joined
Jun 23, 2020
Messages
17
Office Version
  1. 365
  2. 2016
Platform
  1. Windows
I have a workbook that has two sheets in it and I want to compare these sheets (Test1 and Test 2) and highlight only the individual cells that are different/unique. The code I will provide below highlights the row if their is a match but I need the code to highlight only the cell that is NOT a match. I pulled this code from another Forum for help/reference.


VBA Code:
Sub Test_Sheet()

Dim sheetOne As Worksheet
Dim sheetTwo As Worksheet
Dim lastRow As Long
Dim thisRow As Long
Dim lastCol As Long
Dim thisCol As Long
Dim foundRow As Range
Dim lastFoundRow As Long
Dim searchRange As Range
Dim isMatch As Boolean

' Set up the sheets
Set sheetOne = Sheets("Test1")
Set sheetTwo = Sheets("Test 2")

' Find the last row of the active sheet
lastRow = sheetOne.Cells(sheetOne.Rows.Count, "A").End(xlUp).Row

' Set the search range on the other sheet
Set searchRange = sheetTwo.Range("A1:A" & sheetTwo.Cells(sheetTwo.Rows.Count, "A").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

End Sub
 

Excel Facts

Select all contiguous cells
Pressing Ctrl+* (asterisk) will select the "current region" - all contiguous cells in all directions.
Does the entire row need to match or just a targeted cell...
This is just the targeted cell using conditional formatting... no code required
Replace my named ranges with the ranges on the opposite sheets
Book1
ABC
1
2ApplesApples
3BananasBananas
4CherriesDates
5DatesEggplant
6EggplantGrapes
7FigsHoneydew
8Grapes
Sheet1
Cells with Conditional Formatting
CellConditionCell FormatStop If True
C2:C7Expression=COUNTIF(Test1,C2)=0textNO
A2:A8Expression=COUNTIF(Test2,A2)=0textNO
 
Upvote 0
Does the entire row need to match or just a targeted cell...
This is just the targeted cell using conditional formatting... no code required
Replace my named ranges with the ranges on the opposite sheets
Book1
ABC
1
2ApplesApples
3BananasBananas
4CherriesDates
5DatesEggplant
6EggplantGrapes
7FigsHoneydew
8Grapes
Sheet1
Cells with Conditional Formatting
CellConditionCell FormatStop If True
C2:C7Expression=COUNTIF(Test1,C2)=0textNO
A2:A8Expression=COUNTIF(Test2,A2)=0textNO

Just a targeted cell, and I have to put this in a macro.
 
Upvote 0
Are the values in Col A unique, or can they occur multiple times?
 
Upvote 0
The Values in column A are unique yes. They cannot occur multiple times only once
 
Upvote 0
Ok, how about
VBA Code:
Sub Walkerwood()
   Dim Ary1 As Variant, Ary2 As Variant
   Dim r As Long, c As Long
   Dim Ws As Worksheet
   
   Set Ws = Sheets("Test1")
   Ary1 = Ws.Range("A1").CurrentRegion.Value2
   Ary2 = Sheets("Test2").Range("A1").CurrentRegion.Value2
   
   With CreateObject("Scripting.dictionary")
      For r = 1 To UBound(Ary2)
         .Item(Ary2(r, 1)) = r
      Next r
      For r = 1 To UBound(Ary1)
         If .Exists(Ary1(r, 1)) Then
            For c = 1 To UBound(Ary1, 2)
               If Ary1(r, c) <> Ary2(.Item(Ary1(r, 1)), c) Then
                  Ws.Cells(r, c).Interior.Color = vbRed
               End If
            Next c
         Else
            Ws.Rows(r).Interior.Color = vbRed
         End If
      Next r
   End With
End Sub
 
Upvote 0
Getting a subscript out of range error on this line:
If Ary1(r, c) <> Ary2(.Item(Ary1(r, 1)), c) Then
 
Upvote 0

Forum statistics

Threads
1,212,933
Messages
6,110,752
Members
448,295
Latest member
Uzair Tahir Khan

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top