PDA

View Full Version : Compare Two Sheets and Extract Differences



barim
07-12-2018, 07:53 AM
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”.


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”.
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”.
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.

barim
07-12-2018, 12:46 PM
I think I've found some solution to this. I modified Paul Hossler's macro:



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.

mattreingold
07-12-2018, 12:51 PM
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.


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

barim
07-13-2018, 08:31 AM
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.

mattreingold
07-13-2018, 08:41 AM
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.


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