Option Explicit
Dim mbaKeyFields() As Boolean
Dim mbaKeyCols1() As Boolean
Dim mbaKeyCols2() As Boolean
Dim mbaHeadingsInfo() As Boolean
Dim miMaxColumns As Integer
Dim miaHeadingCols1() As Integer
Dim miaHeadingCols2() As Integer
Dim miaKeyFields1() As Integer
Dim miaKeyFields2() As Integer
Dim msaCompareSheets() As String
Dim msResultsSheet As String
Dim msaHeadings1() As String
Dim msaHeadings2() As String
Dim mwsInputs() As Worksheet
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 vaHeadings() As Variant
Dim wsOld As Worksheet, wsNew As Worksheet, wsReport As Worksheet
If GetParameters = False Then Exit Sub
Set wsOld = mwsInputs(0)
Set wsNew = mwsInputs(1)
If PopulateHeadingColumns(WS:=wsOld, _
HeadingsTexts:=msaHeadings1, _
HeadingsColumns:=miaHeadingCols1, _
KeyColumns:=miaKeyFields1) = False Then
Exit Sub
End If
If PopulateHeadingColumns(WS:=wsNew, _
HeadingsTexts:=msaHeadings2, _
HeadingsColumns:=miaHeadingCols2, _
KeyColumns:=miaKeyFields2) = False Then
Exit Sub
End If
miMaxColumns = UBound(msaHeadings1) + 1
Set objDictOld = PopulateDictionary(WS:=wsOld, _
KeyColumns:=miaKeyFields1, _
ColumnPositions:=miaHeadingCols1)
If objDictOld Is Nothing Then
Exit Sub
End If
Set objDictNew = PopulateDictionary(WS:=wsNew, _
KeyColumns:=miaKeyFields2, _
ColumnPositions:=miaHeadingCols2)
If objDictNew Is Nothing Then
Exit Sub
End If
Set wsReport = Sheets(msResultsSheet)
With wsReport.UsedRange
.ClearFormats
.ClearContents
End With
ReDim vaHeadings(1 To 1, 1 To UBound(msaHeadings1) + 2)
For iCol = 0 To UBound(msaHeadings1)
If msaHeadings1(iCol) = msaHeadings2(iCol) Then
vaHeadings(1, iCol + 2) = msaHeadings1(iCol)
Else
vaHeadings(1, iCol + 2) = msaHeadings1(iCol) & " / " & msaHeadings2(iCol)
End If
Next iCol
wsReport.Range("A1", wsReport.Cells(1, UBound(vaHeadings, 2)).Address).Value = vaHeadings
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)
If mbaHeadingsInfo(iCol - 1) = False Then
baChanged(iCol) = True
bChanged = True
End If
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) = wsOld.Name & " only"
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) = wsNew.Name & " only"
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, _
ByRef KeyColumns() As Integer, _
ByRef ColumnPositions() As Integer) As Object
Dim iPtr As Integer
Dim iKeyColsPtr As Integer
Dim iKeyPtr As Integer
Dim iCurCol As Integer
Dim iColEnd As Integer
Dim lRowEnd As Long
Dim lRow As Long
Dim lErrorCount As Long
Dim lDuplicateCount As Long
Dim rCur As Range
Dim sKey As String
Dim sMessage As String
Dim vaItem() As Variant
Dim vaCurRow As Variant
Dim vReply As Variant
With WS.UsedRange
iColEnd = .Column + .Columns.Count - 1
End With
Set PopulateDictionary = Nothing
Set PopulateDictionary = CreateObject("Scripting.Dictionary")
lRowEnd = WS.Cells(Rows.Count, ColumnPositions(0)).End(xlUp).Row
For lRow = 2 To lRowEnd
vaCurRow = WS.Range("A" & lRow).Resize(, iColEnd).Value
sKey = ""
For iKeyColsPtr = LBound(KeyColumns) To UBound(KeyColumns)
iKeyPtr = KeyColumns(iKeyColsPtr)
If iKeyPtr <> 0 Then
sKey = sKey & "|" & LCase$(CStr(vaCurRow(1, iKeyPtr)))
End If
Next iKeyColsPtr
If sKey = "" Then
MsgBox prompt:="No key headings specified", _
Buttons:=vbOKOnly + vbCritical, _
Title:="PARAMETER ERROR"
Set PopulateDictionary = Nothing
Exit Function
End If
sKey = Mid$(sKey, 2)
ReDim vaItem(1 To 1, 1 To UBound(ColumnPositions) + 1)
For iPtr = 0 To UBound(ColumnPositions)
iCurCol = ColumnPositions(iPtr)
vaItem(1, iPtr + 1) = vaCurRow(1, iCurCol)
Next iPtr
If PopulateDictionary.Exists(sKey) Then
lDuplicateCount = lDuplicateCount + 1
If lDuplicateCount < 11 Then
sMessage = sMessage & "Duplicate key in sheet " & WS.Name & " row " & lRow & vbCrLf
End If
Else
On Error Resume Next
PopulateDictionary.Add Key:=sKey, Item:=vaItem
If Err.Number <> 0 Then
If MsgBox(prompt:="Error " & Err.Number & " in sheet " & WS.Name & " row " & lRow & vbCrLf & _
Err.Description & vbCrLf & "Do you wish to ignore this and continue?", _
Buttons:=vbYesNo + vbCritical, _
Title:="ERROR DETECTED") = vbNo Then
Set PopulateDictionary = Nothing
Exit Function
End If
End If
On Error GoTo 0
End If
Next lRow
If lDuplicateCount > 10 Then
sMessage = sMessage & "(Only first 10 duplicate keys displayed)"
End If
If lDuplicateCount > 0 Then
If MsgBox(prompt:=lDuplicateCount & " duplicate keys were ignored:" & vbCrLf & sMessage & _
"Do you wish to continue?", _
Buttons:=vbYesNo + vbCritical, _
Title:="DUPLICATE KEY(S) DETECTED") = vbNo Then
Set PopulateDictionary = Nothing
Exit Function
End If
End If
End Function
Private Function GetParameters() As Boolean
Dim iKeyFieldCount As Integer
Dim iPtr As Integer
Dim iParamCheck As Integer
Const iParamCompareSheets As Integer = 1
Const iParamResultsSheet As Integer = 2
Const iParamHeadings As Integer = 4
Dim lRow As Long
Dim sCurKey As String
Dim saHeadings() As String, saHeadingsA() As String
Dim vaParameters As Variant
Dim wsParams As Worksheet, wsTemp As Worksheet
Set wsParams = Nothing
On Error Resume Next
Set wsParams = Sheets("Parameters")
On Error GoTo 0
If wsParams Is Nothing Then
MsgBox prompt:="Cannot access 'Parameters' sheet", _
Buttons:=vbOKOnly + vbCritical, _
Title:="ERROR"
GetParameters = False
Exit Function
End If
lRow = wsParams.Cells(Rows.Count, "A").End(xlUp).Row
vaParameters = wsParams.Range("A1:B" & lRow).Value
iParamCheck = 0
For lRow = 2 To UBound(vaParameters, 1)
sCurKey = NormaliseText(CStr(vaParameters(lRow, 1)))
Select Case sCurKey
Case "comparesheets"
iParamCheck = iParamCheck Or iParamCompareSheets
msaCompareSheets = Split(CStr(vaParameters(lRow, 2)), ",")
If UBound(msaCompareSheets) <> 1 Then
MsgBox prompt:="'Compare Sheets' parameter has too many elements", Buttons:=vbOKOnly + vbCritical
GetParameters = False
Exit Function
End If
ReDim mwsInputs(0 To 1)
For iPtr = 0 To 1
Set mwsInputs(iPtr) = Nothing
On Error Resume Next
Set mwsInputs(iPtr) = Sheets(Trim$(msaCompareSheets(iPtr)))
On Error GoTo 0
If mwsInputs(iPtr) Is Nothing Then
MsgBox prompt:="Cannot access compare sheet '" & msaCompareSheets(iPtr) & "'", Buttons:=vbOKOnly + vbCritical
GetParameters = False
Exit Function
End If
Next iPtr
Case "resultssheet"
iParamCheck = iParamCheck Or iParamResultsSheet
msResultsSheet = CStr(vaParameters(lRow, 2))
Set wsTemp = Nothing
On Error Resume Next
Set wsTemp = Sheets(msResultsSheet)
On Error GoTo 0
If wsTemp Is Nothing Then
MsgBox prompt:="Cannot access Results sheet '" & msResultsSheet & "'", Buttons:=vbOKOnly + vbCritical
GetParameters = False
Exit Function
End If
Case "headings"
iParamCheck = iParamCheck Or iParamHeadings
saHeadings = Split(CStr(vaParameters(lRow, 2)), ",")
ReDim msaHeadings1(0 To UBound(saHeadings))
ReDim msaHeadings2(0 To UBound(saHeadings))
ReDim miaHeadingCols1(0 To UBound(saHeadings))
ReDim miaKeyFields1(0 To UBound(saHeadings))
ReDim miaKeyFields2(0 To UBound(saHeadings))
ReDim miaHeadingCols2(0 To UBound(saHeadings))
ReDim mbaHeadingsInfo(0 To UBound(saHeadings))
ReDim mbaKeyFields(0 To UBound(saHeadings))
iKeyFieldCount = 0
For iPtr = 0 To UBound(saHeadings)
saHeadingsA = Split("=" & saHeadings(iPtr), "=")
If UBound(saHeadingsA) < 1 Or UBound(saHeadingsA) > 2 Then
MsgBox prompt:="Invalid headings value", Buttons:=vbOKOnly + vbCritical
GetParameters = False
Exit Function
End If
ReDim Preserve saHeadingsA(0 To 2)
saHeadingsA(1) = Trim$(saHeadingsA(1))
mbaHeadingsInfo(iPtr) = LCase$(Left$(saHeadingsA(1) & "123456", 6)) = "(info)"
If mbaHeadingsInfo(iPtr) Then saHeadingsA(1) = Mid$(saHeadingsA(1), 7)
mbaKeyFields(iPtr) = LCase$(Left$(saHeadingsA(1) & "12345", 5)) = "(key)"
If mbaKeyFields(iPtr) Then
iKeyFieldCount = iKeyFieldCount + 1
saHeadingsA(1) = Mid$(saHeadingsA(1), 6)
End If
If saHeadingsA(2) = "" Then saHeadingsA(2) = saHeadingsA(1)
msaHeadings1(iPtr) = saHeadingsA(1)
msaHeadings2(iPtr) = Trim$(saHeadingsA(2))
Next iPtr
If iKeyFieldCount = 0 Then
MsgBox prompt:="No key fields specified", Buttons:=vbOKOnly + vbCritical
GetParameters = False
Exit Function
End If
Case Else
MsgBox prompt:="Unrecognised parameter in row " & lRow, Buttons:=vbOKOnly + vbCritical
GetParameters = False
Exit Function
End Select
Next lRow
If iParamCheck <> 7 Then
MsgBox prompt:="Missing parameter(s)!", Buttons:=vbOKOnly + vbCritical
GetParameters = False
Exit Function
End If
GetParameters = True
End Function
Private Function PopulateHeadingColumns(ByVal WS As Worksheet, _
ByRef HeadingsTexts() As String, _
ByRef HeadingsColumns() As Integer, _
ByRef KeyColumns() As Integer) As Boolean
Dim bFound As Boolean
Dim iPtrCol As Integer, iPtrHeading As Integer, iColEnd As Integer
Dim sCurHeading As String, sCur As String
Dim vaHeadings() As Variant
iColEnd = WS.Cells(1, Columns.Count).End(xlToLeft).Column
vaHeadings = WS.Range("A1:" & WS.Cells(1, iColEnd).Address).Value
For iPtrHeading = LBound(HeadingsTexts) To UBound(HeadingsTexts)
sCurHeading = NormaliseText(HeadingsTexts(iPtrHeading))
bFound = False
For iPtrCol = 1 To UBound(vaHeadings, 2)
If sCurHeading = NormaliseText(CStr(vaHeadings(1, iPtrCol))) Then
HeadingsColumns(iPtrHeading) = iPtrCol
If mbaKeyFields(iPtrHeading) = True Then KeyColumns(iPtrHeading) = iPtrCol
bFound = True
Exit For
End If
Next iPtrCol
If bFound = False Then
MsgBox prompt:="Heading '" & HeadingsTexts(iPtrHeading) & "' not found in sheet '" & WS.Name, _
Buttons:=vbOKOnly + vbCritical
PopulateHeadingColumns = False
Exit Function
End If
Next iPtrHeading
PopulateHeadingColumns = True
End Function
Private Function NormaliseText(ByVal TextString As String) As String
'-- Convert to lower case and remove all but alphanumerics --
Dim iPtr As Integer
Dim sHold As String
Dim sChar As String
Dim sResult As String
sHold = Replace(LCase$(TextString), " ", "")
sResult = ""
For iPtr = 1 To Len(sHold)
sChar = Mid$(sHold, iPtr, 1)
If IsNumeric(sChar) Or sChar <> UCase$(sChar) Then
sResult = sResult & sChar
End If
Next iPtr
NormaliseText = sResult
End Function
