Option Explicit
Dim miMaxColumns As Integer
Dim miaHeadingCols1() As Integer
Dim miaHeadingCols2() As Integer
Dim msaCompareWorkbooks() As String
Dim msResultsSheet As String
Dim msaHeadings1() As String
Dim msaHeadings2() As String
Dim mbaHeadingsInfo() As Boolean
Dim mwbInputs() As Workbook
Dim mwbReport As Workbook
Dim mwsInputs() As Worksheet
Dim mwsReport 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
If GetParameters = False Then Exit Sub
Set wsOld = mwsInputs(1)
Set wsNew = mwsInputs(2)
If PopulateHeadingColumns(WS:=wsOld, HeadingsTexts:=msaHeadings1, HeadingsColumns:=miaHeadingCols1) = False Then
Exit Sub
End If
If PopulateHeadingColumns(WS:=wsNew, HeadingsTexts:=msaHeadings2, HeadingsColumns:=miaHeadingCols2) = False Then
Exit Sub
End If
miMaxColumns = UBound(msaHeadings1) + 1
Set objDictOld = PopulateDictionary(WS:=wsOld, ColumnPositions:=miaHeadingCols1)
Set objDictNew = PopulateDictionary(WS:=wsNew, ColumnPositions:=miaHeadingCols2)
With mwsReport
.Cells.ClearFormats
.Cells.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
mwsReport.Range("A1", mwsReport.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 mwsReport
.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 mwsReport
.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 mwsReport
.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 mwsReport
.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
With Application
.EnableEvents = False
.DisplayAlerts = False
End With
mwbInputs(1).Close savechanges:=False
mwbInputs(2).Close savechanges:=False
Application.EnableEvents = True
End Sub
Private Function PopulateDictionary(ByRef WS As Worksheet, ByRef ColumnPositions() As Integer) As Object
Dim iPtr As Integer, iCurCol As Integer
Dim lRowEnd As Long, lRow As Long
Dim rCur As Range
Dim sKey As String
Dim vaItem() As Variant
Set PopulateDictionary = Nothing
Set PopulateDictionary = CreateObject("Scripting.Dictionary")
lRowEnd = WS.Cells(Rows.Count, ColumnPositions(0)).End(xlUp).Row
For lRow = 2 To lRowEnd
sKey = Trim$(LCase$(CStr(WS.Cells(lRow, ColumnPositions(0)).Value)))
ReDim vaItem(1 To 1, 1 To UBound(ColumnPositions) + 1)
For iPtr = 0 To UBound(ColumnPositions)
iCurCol = ColumnPositions(iPtr)
vaItem(1, iPtr + 1) = WS.Cells(lRow, iCurCol).Value
Next iPtr
On Error Resume Next
PopulateDictionary.Add key:=sKey, Item:=vaItem
On Error GoTo 0
Next lRow
End Function
Private Function GetParameters() As Boolean
Dim iPtr As Integer, iPtr1 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 vInputFiles As Variant, vOutputFile 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 = Replace(LCase$(CStr(vaParameters(lRow, 1))), " ", "")
Select Case sCurKey
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 miaHeadingCols2(0 To UBound(saHeadings))
ReDim mbaHeadingsInfo(0 To UBound(saHeadings))
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)
If saHeadingsA(2) = "" Then saHeadingsA(2) = saHeadingsA(1)
msaHeadings1(iPtr) = saHeadingsA(1)
msaHeadings2(iPtr) = saHeadingsA(2)
Next iPtr
Case Else
MsgBox prompt:="Unrecognised parameter in row " & lRow, Buttons:=vbOKOnly + vbCritical
GetParameters = False
Exit Function
End Select
Next lRow
vInputFiles = Application.GetOpenFilename(filefilter:="compae workbooks (*.xls*),*.xls*", _
Title:="Please select the two input workbooks", _
MultiSelect:=True)
If IsArray(vInputFiles) Then
If UBound(vInputFiles) <> 2 Then
MsgBox prompt:="Please select exactly two input workbooks for comparison", _
Buttons:=vbOKOnly + vbCritical
GetParameters = False
Exit Function
End If
Else
MsgBox prompt:="Macro Abandoned", Buttons:=vbOKOnly + vbInformation
GetParameters = False
Exit Function
End If
ReDim mwbInputs(1 To 2)
ReDim mwsInputs(1 To 2)
Application.EnableEvents = False
iPtr1 = 2
For iPtr = 1 To 2
Set mwbInputs(iPtr) = Workbooks.Open(Filename:=vInputFiles(iPtr1), ReadOnly:=True)
Set mwsInputs(iPtr) = mwbInputs(iPtr).Sheets(1)
iPtr1 = iPtr1 - 1
Next iPtr
vOutputFile = Application.GetSaveAsFilename(filefilter:="Output Workbook (*.xls*),*.xls*", _
Title:="Please select output workbook or [Cancel]")
If vOutputFile = False Then
Set mwbReport = Workbooks.Add
Else
Set mwbReport = Workbooks.Open(Filename:=vOutputFile, ReadOnly:=False)
Application.EnableEvents = True
End If
Application.EnableEvents = True
Set mwsReport = mwbReport.Sheets(1)
GetParameters = True
End Function
Private Function PopulateHeadingColumns(ByVal WS As Worksheet, _
ByRef HeadingsTexts() As String, _
ByRef HeadingsColumns() 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 = Replace(LCase$(HeadingsTexts(iPtrHeading)), " ", "")
bFound = False
For iPtrCol = 1 To UBound(vaHeadings, 2)
If sCurHeading = Replace(LCase$(CStr(vaHeadings(1, iPtrCol))), " ", "") Then
HeadingsColumns(iPtrHeading) = iPtrCol
bFound = True
Exit For
End If
Next iPtrCol
If bFound = False Then
MsgBox prompt:="Heading '" & HeadingsTexts(iPtrHeading) & "' not found in " & WS.Parent.Name, _
Buttons:=vbOKOnly + vbCritical
PopulateHeadingColumns = False
Exit Function
End If
Next iPtrHeading
PopulateHeadingColumns = True
End Function
