Compare two sheets then output differences - SEMI COMPLETED - excel

Question

I currently have a macro that compares two sheets together and highlights the differences. Can someone please help me complete the next function where it outputs to a 3rd document with the differences already highlighted?
Column A contains a unique ID on both Sheet1(new) and Sheet2(old). currently Sheet1 will have new IDs highlighted in green, while changes in existing IDs will be highlighted in yellow wherever the change is.
I've been trying to add the next code where the highlighted differences become generated on 3rd sheet and shows the change but no luck.
Excuse me for my bad programming logic...
Sub Compare()
Compare Macro
Const ID_COL As Integer = 1 'ID is in this column
Const NUM_COLS As Integer = 120 'how many columns are being compared?
Dim shtNew As Excel.Worksheet, shtOld As Excel.Worksheet, shtChange As Excel.Worksheet
Dim rwNew As Range, rwOld As Range, f As Range, rwRes As Range
Dim x As Integer, Id
Dim valOld, valNew
Set dict = CreateObject("Scripting.Dictionary")
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = "Change Report"
Range("A1").Select
ActiveCell.FormulaR1C1 = "Change Type"
Selection.Font.Bold = True
Columns("A:A").EntireColumn.AutoFit
Range("B1").Select
ActiveCell.FormulaR1C1 = "ID"
Selection.Font.Bold = True
Columns("B:B").EntireColumn.AutoFit
Range("C1").Select
ActiveCell.FormulaR1C1 = "Name"
Selection.Font.Bold = True
Columns("C:C").EntireColumn.AutoFit
Range("D1").Select
ActiveCell.FormulaR1C1 = "Product"
Selection.Font.Bold = True
Columns("D:D").EntireColumn.AutoFit
Range("E1").Select
ActiveCell.FormulaR1C1 = "Old"
Selection.Font.Bold = True
Columns("E:E").EntireColumn.AutoFit
Range("F1").Select
ActiveCell.FormulaR1C1 = "New"
Selection.Font.Bold = True
Columns("F:F").EntireColumn.AutoFit
Range("G1").Select
ActiveCell.FormulaR1C1 = "Difference"
Selection.Font.Bold = True
Columns("G:G").EntireColumn.AutoFit
Sheets("Sheet1").Select
Set shtNew = ActiveWorkbook.Sheets("Sheet1")
Set shtOld = ActiveWorkbook.Sheets("Sheet2")
Set shtChange = ActiveWorkbook.Sheets("Change Report")
ActiveWorkbook.Worksheets("Sheet1").AutoFilterMode = False
ActiveWorkbook.Worksheets("Sheet2").AutoFilterMode = False
ActiveWorkbook.Worksheets("Change Report").AutoFilterMode = False
Set rwNew = shtNew.Rows(2) 'first entry on "current" sheet
Set rwRes = shtChange.Rows(2)
ActiveWorkbook.Worksheets("Sheet1").AutoFilterMode = False
ActiveWorkbook.Worksheets("Sheet2").AutoFilterMode = False
Do While rwNew.Cells(ID_COL).Value <> "" 'Compares new Sheet to old Sheet
rwRes.EntireRow(x).Value = rwNew.EntireRow(x).Value
Id = rwNew.Cells(ID_COL).Value
Set f = shtOld.UsedRange.Columns(ID_COL).Find(Id, , xlValues, xlWhole)
If Not f Is Nothing Then
Set rwOld = f.EntireRow
For x = 1 To NUM_COLS
r = 1
If rwNew.Cells(x).Value <> rwOld.Cells(x).Value Then
rwNew.Cells(x).Interior.Color = vbYellow
'rwRes.Cells(r, 2).Value = rwNew.Cells(x, 1).Value 'ID
'rwRes.Cells(r, 3).Value = rwNew.Cells(x, 11).Value 'Name
'rwRes.Cells(r, 4).Value = rwNew.Cells(x, 12).Value 'Product
'rwRes.Cells(r, 5).Value = rwOld.Cells(x, 14).Value 'Price old
'rwRes.Cells(r, 6).Value = rwNew.Cells(x, 14).Value 'Price new
'Percentage Change from old to new 'Difference
r = r + 1
Else
rwNew.Cells(x).Interior.ColorIndex = xlNone
End If
Next x
Else
rwNew.EntireRow.Interior.Color = vbGreen 'new entry
'rwRes.Cells(r, x).Value = rwNew.Cells(x, 1).Value
'rwRes.Cells(r, 2).Value = rwNew.Cells(x, 1).Value 'ID
'rwRes.Cells(r, 3).Value = rwNew.Cells(x, 11).Value 'Name
'rwRes.Cells(r, 4).Value = rwNew.Cells(x, 12).Value 'Product
'rwRes.Cells(r, 6).Value = rwNew.Cells(x, 14).Value 'Price
r = r + 1
End If
Set rwNew = rwNew.Offset(1, 0) 'next row to compare
Loop
Selection.AutoFilter
MsgBox ("Complete")
End Sub

Answer 1

As an alternative to the solution posted by Thomas, you can make use of dictionaries to store indexes for each unique ID, and relevant columns. By population of the dictionaires in loops based on the hardcoded arrays (vHeader and vLookFor) and the range.find method, this enables you to change the position of columns and to some extent behaviour of the code without having to worry about indexes further down.
The script first populates up the dictionaries for header and ID's for the new and old sheets, and then loops the new ID keys to find the ones that had a change to any of the fields set as relevant in the vLookFor, and the ones that are brand new.
The use of the function columnLetter in the creation of the shtChange header range ensures that if you add a field to the vheader it will automatically be added to the shtChange.To avoid having to remove the shtChange in case you want to rerun the macro, I've added a doExist function - it simply deletes the sheet and returns a new worksheet object of the same name.
In case a difference, or a new field is identified, the line is moved to the shtChange and the difference calculated (New price/Old price in %).
Changing the order of columns would at the present wreck you field by field check for all 120 columns, but you could update this to use a dictionary, or more specifically range.find, mitigating the sort of stuff users tend to do (moving columns, sorting etc.) - but blame you for.
Sub Compare()
'reference to Microsoft scripting runtime is a prerequisite for Dictionaries to work
'can the shtOld.usedrange.columns.count potentially substitute this hardcode?
Const ID_COL As Integer = 1 'ID is in this column
Const NUM_COLS As Integer = 120 'how many columns are being compared
Dim shtNew As Worksheet, shtOld As Worksheet, shtChange As Worksheet
Dim vHeader As Variant
Dim vLookFor As Variant
Dim vElement As Variant
Dim vKeyID As Variant
Dim vKeyValueIdx As Variant
Dim oldRowIdx As Variant
Dim oldColIdx As Variant
Dim newRowIdx As Variant
Dim newColIdx As Variant
Dim chgRowIdx As Long
Dim oldPriceIdx As Long
Dim newPriceIdx As Long
Dim diffPriceIdx As Long
Dim chgTypeIdx As Long
Dim shtChangeName As String
Dim oldIndexDict As Dictionary
Dim oldIdRowDict As Dictionary
Dim newIndexDict As Dictionary
Dim newIdRowDict As Dictionary
Dim chgIndexDict As Dictionary
Dim i As Long, j As Long, k As Long, m As Long, n As Long
Dim x As Integer, Id
Dim valOld, valNew
'some intital parameters
shtChangeName = "Change Report"
'rather than printing the header one value at a time, then you can simply place an array directly into the range
vHeader = Array("Change Type", "ID", "Name", "Product", "Old Price", "New Price", "Difference")
'we create a array for the headers that we will be looking for, for the shtChange
vLookFor = Array("ID", "Name", "Product", "Price")
'setting the worksheet object
Set shtNew = ThisWorkbook.Sheets("Sheet1")
Set shtOld = ThisWorkbook.Sheets("Sheet2")
'add the shtChange
Set shtChange = doExist(shtChangeName) 'I really hate having to manually delete a worksheets in case I want to rerun, so I added the doExist function to delete the sheet if it allready exist
'disable any data fitler
shtNew.AutoFilterMode = False
shtOld.AutoFilterMode = False
'Generating the bold headers for the change sheet, to avoid retyping the range over and over again, we use with
With shtChange.Range("A1:" & ColumnLetter(UBound(vHeader) + 1) & "1") 'this is implicitly repeated for all rows, e.g. '.value' -> 'shtChange.Range("A1:G1").value'
.Value = vHeader
.Font.Bold = True
End With
'I will be using dictionaries to find my way around the position of specific headers and ID's. This I do for added robustness, in case the business decides to move columns, change the sorting etc. in only the old or new sheet
Set oldIndexDict = CreateObject("Scripting.Dictionary") 'for header index
Set oldIdRowDict = CreateObject("Scripting.Dictionary") 'for ID row index
Set newIndexDict = CreateObject("Scripting.Dictionary") 'for header index
Set newIdRowDict = CreateObject("Scripting.Dictionary") 'for ID row index
Set chgIndexDict = CreateObject("Scripting.Dictionary") 'for header index
'we populate the index dictionaries
For Each vElement In vLookFor
If Not newIndexDict.Exists(CStr(vElement)) Then
oldIndexDict.Add CStr(vElement), shtOld.Range("1:1").Find(what:=CStr(vElement), LookIn:=xlValues, LookAt:=xlWhole).Column
newIndexDict.Add CStr(vElement), shtNew.Range("1:1").Find(what:=CStr(vElement), LookIn:=xlValues, LookAt:=xlWhole).Column
On Error Resume Next
chgIndexDict.Add CStr(vElement), shtChange.Range("1:1").Find(what:=CStr(vElement), LookIn:=xlValues, LookAt:=xlWhole).Column
On Error GoTo 0
End If
Next
'In case the data is not ordered exactly the same in the new and old sheets, we populate the IdRow dictionaries to enable us to find the position of a specific ID in either sheet
'first the oldSht
For i = 2 To shtOld.UsedRange.Rows.Count 'be aware that if your data does not start on row 1, the usedrange will not accurately reflect the true last row number
If Not oldIdRowDict.Exists(CStr(shtOld.Cells(i, oldIndexDict("ID")))) And CStr(shtOld.Cells(i, oldIndexDict("ID"))) <> "" Then
oldIdRowDict.Add CStr(shtOld.Cells(i, oldIndexDict("ID"))), i
End If
Next
'then the newSht
For j = 2 To shtNew.UsedRange.Rows.Count 'be aware that if your data does not start on row 1, the usedrange will not accurately reflect the true last row number
If Not newIdRowDict.Exists(CStr(shtNew.Cells(j, newIndexDict("ID")))) And CStr(shtNew.Cells(j, newIndexDict("ID"))) <> "" Then
newIdRowDict.Add CStr(shtNew.Cells(j, newIndexDict("ID"))), j
End If
Next
'get indexes for fields specific for shtChange
chgTypeIdx = shtChange.Range("1:1").Find(what:="Change Type", LookIn:=xlValues, LookAt:=xlWhole).Column 'index for changetype
oldPriceIdx = shtChange.Range("1:1").Find(what:="Old Price", LookIn:=xlValues, LookAt:=xlWhole).Column 'index for old price
newPriceIdx = shtChange.Range("1:1").Find(what:="New Price", LookIn:=xlValues, LookAt:=xlWhole).Column 'indexd for new price
diffPriceIdx = shtChange.Range("1:1").Find(what:="Difference", LookIn:=xlValues, LookAt:=xlWhole).Column 'index for difference column
'then we loop the keys in the New sheet and make the relevant comparision, incl. move to shtChange
For Each vKeyID In newIdRowDict.Keys
'retrieve the relevant indexes for the columns going into the shtChange
newRowIdx = newIdRowDict(vKeyID)
If oldIdRowDict.Exists(vKeyID) Then
oldRowIdx = oldIdRowDict(vKeyID)
For Each vKeyValueIdx In newIndexDict.Keys
If shtOld.Cells(oldRowIdx, oldIndexDict(vKeyValueIdx)) <> shtNew.Cells(newRowIdx, newIndexDict(vKeyValueIdx)) Then
chgRowIdx = shtChange.UsedRange.Rows.Count + 1
shtChange.Cells(chgRowIdx, chgTypeIdx) = "Update" 'the key allready existed in the old sheet, so update
For m = LBound(vLookFor) To UBound(vLookFor)
If chgIndexDict.Exists(vLookFor(m)) Then
shtChange.Cells(chgRowIdx, chgIndexDict(vLookFor(m))) = shtNew.Cells(newRowIdx, newIndexDict(vLookFor(m)))
End If
Next
shtChange.Cells(chgRowIdx, oldPriceIdx) = shtOld.Cells(oldRowIdx, oldIndexDict("Price"))
shtChange.Cells(chgRowIdx, newPriceIdx) = shtNew.Cells(newRowIdx, newIndexDict("Price"))
shtChange.Cells(chgRowIdx, diffPriceIdx) = shtChange.Cells(chgRowIdx, newPriceIdx) / shtChange.Cells(chgRowIdx, oldPriceIdx)
End If
Next
shtChange.Columns(diffPriceIdx).NumberFormat = "0.0%"
'This is subject to risk of moved columns etc., but to retain functionality of the posted code we loop all columns the respective ID, and set the colors
For k = 1 To NUM_COLS
If shtOld.Cells(oldRowIdx, k).Value <> shtNew.Cells(newRowIdx, k).Value Then
shtNew.Cells(newRowIdx, k).Interior.Color = vbYellow
Else
shtNew.Cells(newRowIdx, k).Interior.ColorIndex = xlNone
End If
Next
Else 'it is a new entry
shtNew.Range("A" & newRowIdx).EntireRow.Interior.Color = vbGreen 'new entry
chgRowIdx = shtChange.UsedRange.Rows.Count + 1
For n = LBound(vLookFor) To UBound(vLookFor) 'loops the elements of the search fields, and if they exist in shtChange, we fetch the value from shtNew
If chgIndexDict.Exists(vLookFor(n)) Then
shtChange.Cells(chgRowIdx, chgIndexDict(vLookFor(n))) = shtNew.Cells(newRowIdx, newIndexDict(vLookFor(n)))
End If
Next
shtChange.Cells(chgRowIdx, chgTypeIdx) = "New" 'key is new, so New
shtChange.Cells(chgRowIdx, newPriceIdx) = shtNew.Cells(newRowIdx, newIndexDict("Price")) 'since the element is new, only the new price is relevant for shtChange
End If
Next
shtChange.Range("A1:G1").Columns.AutoFit
shtChange.Range("A1").AutoFilter
'set the dicts to nothing
Set oldIndexDict = Nothing
Set oldIdRowDict = Nothing
Set newIndexDict = Nothing
Set newIdRowDict = Nothing
Set chgIndexDict = Nothing
MsgBox ("Complete")
End Sub
Function doExist(strSheetName) As Worksheet
Dim wb As Workbook: Set wb = ThisWorkbook
Dim wsTest As Worksheet
Dim nWs As Worksheet
Set wsTest = Nothing
On Error Resume Next
Set wsTest = wb.Worksheets(strSheetName)
On Error GoTo 0
If Not wsTest Is Nothing Then
Application.DisplayAlerts = False
wsTest.Delete
Application.DisplayAlerts = True
End If
Set doExist = wb.Worksheets.Add(after:=wb.Sheets(wb.Sheets.Count))
doExist.Name = strSheetName
End Function
Function ColumnLetter(ColumnNumber As Long) As String
Dim n As Long
Dim c As Byte
Dim s As String
n = ColumnNumber
Do
c = ((n - 1) Mod 26)
s = Chr(c + 65) & s
n = (n - c) \ 26
Loop While n > 0
ColumnLetter = s
End Function

Answer 2

You're going to need to set a reference to the Microsoft Scripting Runtime.
This should be really close to what you want.
ProductRecord: Stores all the variable to be written to the new worksheet
dProducts: Is a dictionary that holds the ProductRecords
Iterate Sheet1 adding products to dProducts by ID if there they cells are colored
Iterate Sheet2 searching for dProducts by ID. If found we set the product's Old Price
Iterate Worksheet("Change Report") Pasting the products in dProducts as we go
Class ProductRecord
Option Explicit
Public ChangeType As String
Public ID As String
Public Name As String
Public Product As String
Public OldPrice As Double
Public NewPrice As Double
Public Difference As Double
Public Color As Long
Public Sub Paste(Destination As Range)
Dim arData(5)
Difference = NewPrice - OldPrice
If Color = vbGreen Then ChangeType = "New Product" Else ChangeType = "ID Change"
arData(0) = ChangeType
arData(1) = Name
arData(2) = Product
arData(3) = OldPrice
arData(4) = NewPrice
arData(5) = Difference
Destination.Resize(1, 6) = arData 'WorksheetFunction.Transpose(arData)
Destination.Interior.Color = Color
End Sub
The rest of the story
Option Explicit
Sub Compare()
ToggleEvents False
Dim shtNew As Excel.Worksheet, shtOld As Excel.Worksheet, shtChange As Excel.Worksheet
Dim rwNew As Range
Dim k As String
Dim lastRow As Long, x As Long, y
Dim Product As ProductRecord
Dim dProducts As Dictionary
Set dProducts = New Dictionary
Set shtNew = Sheets("Sheet1")
Set shtOld = Sheets("Sheet2")
shtNew.AutoFilterMode = False
shtOld.AutoFilterMode = False
With shtNew
lastRow = .Range("A" & Rows.Count).End(xlUp).Row
For x = 2 To lastRow
For Each y In Array(1, 11, 12, 14)
If .Cells(x, y).Interior.color = vbYellow Or .Cells(x, y).Interior.color = vbGreen Then
Set Product = New ProductRecord
k = .Cells(x, 1).Value
Product.color = .Cells(x, y).Interior.color
Product.ID = .Cells(x, 1).Value 'ID
Product.Name = .Cells(x, 11).Value 'Name
Product.Product = .Cells(x, 12).Value 'Product
Product.NewPrice = .Cells(x, 14).Value 'Price old
If Not dProducts.Exists(k) Then
dProducts.Add k, Product
Exit For
End If
End If
Next
Next
End With
If dProducts.Count > 0 Then
With shtOld
lastRow = .Range("A" & Rows.Count).End(xlUp).Row
For x = 2 To lastRow
k = .Cells(x, 1).Value
If dProducts.Exists(k) Then
dProducts(k).OldPrice = .Cells(x, 14).Value 'ID
End If
Next
End With
End If
Set shtChange = getChangeReportWorkSheet
With shtChange.Range("A1:G1")
.Value = Array("Change Type", "ID", "Name", "Product", "Old", "New", "Difference")
Selection.Font.Bold = True
End With
With shtChange
lastRow = dProducts.Count - 1
For x = 0 To lastRow
dProducts.Items(x).Paste .Cells(x + 2, 1)
Next
.Range("A1:G1").EntireColumn.AutoFit
End With
ToggleEvents True
'Selection.AutoFilter
MsgBox ("Complete")
End Sub
Sub ToggleEvents(EnableEvents As Boolean)
With Application
.EnableEvents = EnableEvents
.Calculation = IIf(EnableEvents, xlCalculationAutomatic, xlCalculationManual)
End With
End Sub
Function getChangeReportWorkSheet() As Worksheet
Application.DisplayAlerts = False
On Error Resume Next
Worksheets("Change Report").Delete
On Error GoTo 0
Application.DisplayAlerts = True
Set getChangeReportWorkSheet = Sheets.Add(After:=Sheets(Sheets.Count))
getChangeReportWorkSheet.Name = "Change Report"
End Function