Option Explicit
Dim miMaxColumns As Integer
Sub CompareSheets()
Dim bChanged As Boolean, baChanged() As Boolean
Dim iColEnd As Integer, iCol As Integer, iCol1 As Integer, iCol2 As Integer
Dim lRow1 As Long, lRow2 As Long, lReportRow As Long
Dim objDictOld As Object, objDictNew As Object
Dim vKeys As Variant, vKey As Variant
Dim vaInput() As Variant, vaOutput() As Variant, vaOutput2() As Variant
Dim vaInputOld As Variant, vaInputNew As Variant
Dim wsOld As Worksheet, wsNew As Worksheet, wsReport As Worksheet
Set wsOld = Sheets("Sheet1")
miMaxColumns = wsOld.Cells(1, Columns.Count).End(xlToLeft).Column
Set objDictOld = PopulateDictionary(WS:=wsOld)
Set wsNew = Sheets("Sheet2")
Set objDictNew = PopulateDictionary(WS:=wsNew)
Set wsReport = Sheets("Sheet3")
With wsReport
.Cells.ClearFormats
.Cells.ClearContents
End With
wsOld.Range("A1:" & wsOld.Cells(1, miMaxColumns).Address).Copy
wsReport.Range("B1").PasteSpecial xlPasteValues
Application.CutCopyMode = False
lReportRow = 1
vKeys = objDictOld.Keys
For Each vKey In vKeys
ReDim vaInputOld(1 To 1, 1 To miMaxColumns)
vaInputOld = objDictOld.Item(vKey)
If objDictNew.exists(vKey) Then
ReDim vaInputNew(1 To 1, 1 To miMaxColumns)
vaInputNew = objDictNew.Item(vKey)
ReDim vaOutput(1 To 1, 1 To miMaxColumns + 1)
ReDim vaOutput2(1 To 1, 1 To miMaxColumns + 1)
ReDim baChanged(1 To miMaxColumns)
bChanged = False
For iCol = 1 To miMaxColumns
vaOutput(1, iCol + 1) = vaInputOld(1, iCol)
If vaInputOld(1, iCol) <> vaInputNew(1, iCol) Then
vaOutput2(1, iCol + 1) = vaInputNew(1, iCol)
baChanged(iCol) = True
bChanged = True
End If
Next iCol
If bChanged Then
lReportRow = lReportRow + 1
For iCol = 1 To UBound(baChanged)
If baChanged(iCol) Then
With wsReport
.Range(.Cells(lReportRow, iCol + 1).Address, _
.Cells(lReportRow + 1, iCol + 1).Address).Interior.Color = vbYellow
End With
End If
Next iCol
vaOutput(1, 1) = "Changed"
With wsReport
.Range(.Cells(lReportRow, 1).Address, _
.Cells(lReportRow, miMaxColumns + 1).Address).Value = vaOutput
lReportRow = lReportRow + 1
.Range(.Cells(lReportRow, 1).Address, _
.Cells(lReportRow, miMaxColumns + 1).Address).Value = vaOutput2
End With
End If
objDictOld.Remove vKey
objDictNew.Remove vKey
Else
ReDim vaOutput(1 To 1, 1 To miMaxColumns + 1)
vaOutput(1, 1) = "Deleted"
For iCol = 1 To miMaxColumns
vaOutput(1, iCol + 1) = vaInputOld(1, iCol)
Next iCol
lReportRow = lReportRow + 1
With wsReport
.Range(.Cells(lReportRow, 1).Address, .Cells(lReportRow, miMaxColumns + 1).Address).Value = vaOutput
'-- Set the row to light grey
.Range(.Cells(lReportRow, 2).Address, .Cells(lReportRow, miMaxColumns + 1).Address).Interior.ColorIndex = 15
End With
End If
Next vKey
If objDictNew.Count <> 0 Then
vKeys = objDictNew.Keys
For Each vKey In vKeys
ReDim vaOutput2(1 To 1, 1 To miMaxColumns + 1)
vaInputNew = objDictNew.Item(vKey)
vaOutput2(1, 1) = "Inserted"
For iCol = 1 To miMaxColumns
vaOutput2(1, iCol + 1) = vaInputNew(1, iCol)
Next iCol
lReportRow = lReportRow + 1
With wsReport
.Range(.Cells(lReportRow, 1).Address, .Cells(lReportRow, miMaxColumns + 1).Address).Value = vaOutput2
'-- Set the row to light green
.Range(.Cells(lReportRow, 2).Address, .Cells(lReportRow, miMaxColumns + 1).Address).Interior.ColorIndex = 4
End With
Next vKey
End If
objDictOld.RemoveAll
Set objDictOld = Nothing
objDictNew.RemoveAll
Set objDictNew = Nothing
End Sub
Private Function PopulateDictionary(ByRef WS As Worksheet) As Object
Dim lRowEnd As Long, lRow As Long
Dim rCur As Range
Dim sKey As String
Set PopulateDictionary = Nothing
Set PopulateDictionary = CreateObject("Scripting.Dictionary")
lRowEnd = WS.Cells(Rows.Count, "A").End(xlUp).Row
For lRow = 2 To lRowEnd
sKey = Trim$(LCase$(CStr(WS.Range("A" & lRow).Value)))
On Error Resume Next
PopulateDictionary.Add key:=sKey, Item:=WS.Range(WS.Cells(lRow, 1).Address, _
WS.Cells(lRow, miMaxColumns).Address).Value
On Error GoTo 0
Next lRow
End Function
