Compare Two Sheets and Extract Differences

I already have a macro that will compare two worksheets and highlight differences. Now, I need a report that would be in a separate worksheet called “Report”.

1. Wherever there is anything highlighted in the row, I want that whole row copied and pasted into “Report” sheet. “Status” column should be marked as “Change”.
2. If there are any new rows in “New” sheet they should be copied and pasted in “Report” sheet. “Status” column should be marked as “Add”.
3. In the case that there are some missing rows in “New” sheet, but they existed in the “Old”, I want those rows copied and pasted from “Old” into “Report”. “Status” column should be marked as “Missing”.

Please see attached sample file. Let me know if you need more information. I appreciate help on this.

I think I've found some solution to this. I modified Paul Hossler's macro:

Code:

---

Sub HighlightChanges()
    Dim rDatabase As Range, rFile As Range
    Dim iFile As Long, iDatabase As Long, iColumn As Long
   
    Set rDatabase = Worksheets("Old").Cells(1, 1).CurrentRegion
    Set rFile = Worksheets("New").Cells(1, 1).CurrentRegion
   
    rFile.Interior.Color = xlNone
   
    For iFile = 2 To rFile.Rows.Count
       
        iDatabase = -1
       
        On Error Resume Next
        iDatabase = Application.WorksheetFunction.Match(rFile.Cells(iFile, 1).Value, rDatabase.Columns(1), 0)
        On Error GoTo 0
       
        If iDatabase <> -1 Then
            For iColumn = 2 To rFile.Columns.Count
                '  changed to add CStr()'s
                If CStr(rFile.Cells(iFile, iColumn).Value) <> CStr(rDatabase.Cells(iDatabase, iColumn).Value) Then
                    rFile.Cells(iFile, iColumn).Interior.Color = vbGreen
                Else
                    rFile.Cells(iFile, iColumn).Interior.Color = vbYellow
                End If
            Next iColumn
        End If
    Next iFile
   
End Sub

---

Cells that have difference, highlight in green, cells that have no difference highlight in yellow, those that are not highlighted are new products.

If I switch worksheet names, I will get all missing lines from "New".

Now, what's left is to transfer whole rows that have any cells highlighted in green and those without any highlights.

Barim, I begun work on this and got the "Change" case where if it is highlighted, add it to the report sheet, see below code.

After you implement this, let me know what you still need. I would have it all done, however some of your requests are a bit confusing.

For example:
-For the change case, are rows only ever going to be highlighted in the "New" sheet? Also, only rows D-F? Or A-F?
-For the "Add" case, are you comparing the rows of OLD and NEW and if NEW has something that OLD doesnt, add it to report?

Let me know if you need anything further.

Code:

---

Sub RunReport()
Dim WBT As Workbook
Dim WPN As Worksheet
Dim oldSheet As Worksheet
Dim newSheet As Worksheet
Dim ListOld(), ListNew()
Dim change As String
Dim add As String
Dim missing As String
change = "Change"
add = "Add"
missing = "Missing"


' Set workbook/worksheet variables
Set WBT = ThisWorkbook
Set WPN = WBT.Sheets(3)
Set oldSheet = WBT.Sheets(1)
Set newSheet = WBT.Sheets(2)


firstRow = 2 ' Row after header
lastRowOld = oldSheet.Cells(Rows.Count, "A").End(xlUp).Row
lastRowNew = newSheet.Cells(Rows.Count, "A").End(xlUp).Row
reportLastRow = WPN.Cells(Rows.Count, "A").End(xlUp).Row


With oldSheet
    ListOld = Range(.Cells(firstRow, 2), .Cells(lastRowOld, 2)).Value
End With
With newSheet
    ListNew = Range(.Cells(firstRow, 2), .Cells(lastRowNew, 2)).Value
End With


' New Case
Dim ColorValues() As Variant
ReDim ColorValues(LBound(ListNew) To UBound(ListNew))
Dim table As Range
For i = LBound(ColorValues) To UBound(ColorValues)
    Set table = newSheet.Range("C" & i)
    ColorValues(i) = table.Interior.Color
    If ColorValues(i) <> 16777215 Then
        newSheet.Rows(i).Copy WPN.Rows(reportLastRow + 1)
        newSheet.Cells(reportLastRow, 6).Value = change
        reportLastRow = reportLastRow + 1
    End If
   
    Set table = newSheet.Range("D" & i)
    ColorValues(i) = table.Interior.Color
    If ColorValues(i) <> 16777215 Then
        newSheet.Rows(i).Copy WPN.Rows(reportLastRow + 1)
        newSheet.Cells(reportLastRow, 6).Value = change
        reportLastRow = reportLastRow + 1
    End If
   
    Set table = newSheet.Range("E" & i)
    ColorValues(i) = table.Interior.Color
    If ColorValues(i) <> 16777215 Then
        newSheet.Rows(i).Copy WPN.Rows(reportLastRow + 1)
        newSheet.Cells(reportLastRow, 6).Value = change
        reportLastRow = reportLastRow + 1
    End If
Next i


End Sub

---

Mattreingold, thank you so much for writing these codes.

I tested your codes and it seems it is not "picking up".

The first columns in both sheets are a lookup values and everything from B to E should be highlighted based on if anything changed. Column F in Report tab is just to print status of each line, based on which color.
If there is any cell in the line highlighted as green it should be "Change"
If the line is completely yellow it should be no action.
If the line is not colored at all that should be "Add"

Since, all changes are happening in "New" tab, with the above code I reverse sheet references just to find what is missing from new tab.

I attached Example. As you can see in the Old tab one line is not highlighted which means it is missing in New. That line should be transferred to report tab and marked as "Missing". This should be the only type that should come from old tab. Sorry for this turned so complicated. What is more important to me is to transfer these lines into report tab, if statuses are so complicated to do maybe I can do something with conditional formatting.
Again, thank you so much for your effort.

Barim, I dont think the yellow/green highlighting is necessary. I can write you a piece of code that can recognize if something is not found in another location (I see in your example that Product 9 is missing from NEW, I can write code to recognize that).

Instead, what would be helpful is if only the green highlighting is used, that makes the "Change" case easier, by recognizing if the cell is highlighted at all.

I can continue helping monday, however this code should work below for the 'Change' case:

I edited it slightly based on the example you provided, so it should run smoothly. (I don't know what you mean its not "picking up")

NOTE: You need to remove the yellow highlighting for this to work, this runs based on which cells are highlighted. I will add segments about Add and Missing monday, but the only highlighting should be done is the green for the 'change' case.

Code:

---

Sub RunReport()
Dim WBT As Workbook
Dim WPN As Worksheet
Dim oldSheet As Worksheet
Dim newSheet As Worksheet
Dim ListOld(), ListNew()
Dim change As String
Dim add As String
Dim missing As String
change = "Change"
add = "Add"
missing = "Missing"




' Set workbook/worksheet variables
Set WBT = ThisWorkbook
Set WPN = WBT.Sheets(3)
Set oldSheet = WBT.Sheets(1)
Set newSheet = WBT.Sheets(2)




firstRow = 2 ' Row after header
lastRowOld = oldSheet.Cells(Rows.Count, "A").End(xlUp).Row
lastRowNew = newSheet.Cells(Rows.Count, "A").End(xlUp).Row
reportLastRow = WPN.Cells(Rows.Count, "A").End(xlUp).Row




With oldSheet
    ListOld = Range(.Cells(firstRow, 2), .Cells(lastRowOld, 2)).Value
End With
With newSheet
    ListNew = Range(.Cells(firstRow, 2), .Cells(lastRowNew, 2)).Value
End With




' New Case
Dim ColorValues() As Variant
ReDim ColorValues(LBound(ListNew) To UBound(ListNew))
Dim table As Range
For i = LBound(ColorValues) To UBound(ColorValues)
    Set table = newSheet.Range("C" & i)
    ColorValues(i) = table.Interior.Color
    If ColorValues(i) <> 16777215 Then
        newSheet.Rows(i).Copy WPN.Rows(reportLastRow + 1)
        WPN.Cells(reportLastRow + 1, 6).Value = change
        reportLastRow = reportLastRow + 1
    End If
   
    Set table = newSheet.Range("D" & i)
    ColorValues(i) = table.Interior.Color
    If ColorValues(i) <> 16777215 Then
        newSheet.Rows(i).Copy WPN.Rows(reportLastRow + 1)
        WPN.Cells(reportLastRow + 1, 6).Value = change
        reportLastRow = reportLastRow + 1
    End If
   
    Set table = newSheet.Range("E" & i)
    ColorValues(i) = table.Interior.Color
    If ColorValues(i) <> 16777215 Then
        newSheet.Rows(i).Copy WPN.Rows(reportLastRow + 1)
        WPN.Cells(reportLastRow + 1, 6).Value = change
        reportLastRow = reportLastRow + 1
    End If
Next i




End Sub

---