Option Explicit
Const msOldSheetname As String = "KPMG"
Const msNewSheetName As String = "Client"
Const msReportSheetName As String = "ExceptionSummary"
Const msActionChanged As String = "Changed"
Const msActtionInserted As String = "Inserted"
Const msActionDeleted As String = "Deleted"
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 sChangeType As String
Dim sCurKey As String
Dim vKeys As Variant, vKey As Variant
Dim vaInput As Variant, vaOutput As Variant
Dim vaHeadings As Variant
Dim vaHeadingsNew As Variant
Dim vaInputOld As Variant, vaInputNew As Variant
Dim wsOld As Worksheet, wsNew As Worksheet, wsReport As Worksheet
Set wsOld = Sheets(msOldSheetname)
miMaxColumns = wsOld.Cells(1, Columns.Count).End(xlToLeft).Column
Set objDictOld = PopulateDictionary(WS:=wsOld)
Set wsNew = Sheets(msNewSheetName)
Set objDictNew = PopulateDictionary(WS:=wsNew)
vaHeadings = wsOld.Range("A1:" & wsOld.Cells(1, miMaxColumns).Address).Value
vaHeadingsNew = wsNew.Range("A1:" & wsNew.Cells(1, miMaxColumns).Address).Value
For iCol = 1 To UBound(vaHeadingsNew, 2)
If LCase$(CStr(vaHeadingsNew(1, iCol))) <> LCase$(CStr(vaHeadings(1, iCol))) Then
vaHeadings(1, iCol) = vaHeadings(1, iCol) & " (" & vaHeadingsNew(1, iCol) & ")"
End If
Next iCol
Set wsReport = Sheets(msReportSheetName)
With wsReport
.Cells.ClearContents
End With
lReportRow = 1
ReDim vaOutput(1 To 1, 1 To 5)
vaOutput = Array("Type", "Key", "Field", wsOld.Name, wsNew.Name)
wsReport.Range("A1:E1").Value = vaOutput
vKeys = objDictOld.Keys
For Each vKey In vKeys
ReDim vaInputOld(1 To 1, 1 To miMaxColumns)
vaInputOld = objDictOld.Item(vKey)
ReDim vaOutput(1 To 1, 1 To 5)
vaOutput(1, 2) = vKey
ReDim vaInputNew(1 To 1, 1 To miMaxColumns)
If objDictNew.exists(vKey) Then
sChangeType = msActionChanged
vaInputNew = objDictNew.Item(vKey)
Else
sChangeType = msActionDeleted
End If
ReportChanges ChangeType:=sChangeType, _
Key:=vKey, _
OldData:=vaInputOld, _
NewData:=vaInputNew, _
Headings:=vaHeadings, _
ReportRow:=lReportRow, _
wsReport:=wsReport
On Error Resume Next
objDictOld.Remove vKey
objDictNew.Remove vKey
On Error GoTo 0
Next vKey
If objDictNew.Count <> 0 Then
vKeys = objDictNew.Keys
ReDim vaInputOld(1 To 1, 1 To miMaxColumns)
For Each vKey In vKeys
vaInputNew = objDictNew.Item(vKey)
ReportChanges ChangeType:=msActtionInserted, _
Key:=vKey, _
OldData:=vaInputOld, _
NewData:=vaInputNew, _
Headings:=vaHeadings, _
ReportRow:=lReportRow, _
wsReport:=wsReport
Next vKey
End If
objDictOld.RemoveAll
Set objDictOld = Nothing
objDictNew.RemoveAll
Set objDictNew = Nothing
End Sub
Private Sub ReportChanges(ByVal ChangeType As String, _
ByVal Key As Variant, _
ByVal OldData As Variant, _
ByRef NewData As Variant, _
ByRef Headings As Variant, _
ByRef ReportRow As Long, _
ByRef wsReport As Worksheet)
Dim baChanged() As Boolean
Dim bChanged As Boolean
Dim iCol As Integer
Dim vaOutput As Variant
ReDim vaOutput(1 To 1, 1 To 5)
vaOutput(1, 1) = ChangeType
vaOutput(1, 2) = Key
ReDim baChanged(1 To UBound(OldData, 2))
bChanged = False
For iCol = 1 To UBound(baChanged)
If OldData(1, iCol) <> NewData(1, iCol) Then
vaOutput(1, 3) = Headings(1, iCol)
vaOutput(1, 4) = OldData(1, iCol)
vaOutput(1, 5) = NewData(1, iCol)
ReportRow = ReportRow + 1
wsReport.Range("A" & ReportRow).Resize(, UBound(vaOutput, 2)).Value = vaOutput
End If
Next iCol
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
