Dim mbaKeyFields() As Boolean
Dim mbaKeyCols1() As Boolean
Dim mbaKeyCols2() As Boolean
Dim mbaHeadingsInfo() As Boolean
Dim mbIgnoreCase As Boolean
Dim mbDisplayOutputHeadings As Boolean
Dim mbFilterKey As Boolean
Dim mbShowUnchangedCells As Boolean
Dim mbaReportSheetsInitialised() As Boolean
Dim mdblTolerance As Double
Dim miMaxColumns As Integer
Dim miaHeadingCols1() As Integer
Dim miaHeadingCols2() As Integer
Dim miaKeyFields1() As Integer
Dim miaKeyFields2() As Integer
Const mlResultsPtrDupKey1 As Long = 1
Const mlResultsPtrDupKey2 As Long = 2
Const mlResultsPtrMismatched As Long = 3
Const mlResultsPtrMatched As Long = 4
Const mlResultsPtrData1Only As Long = 5
Const mlResultsPtrData2Only As Long = 6
Dim mlErrorRow As Long
Dim mlReportRow As Long
Dim mlaResultsSheetsPtrs(1 To 6) As Long
Dim mlRounding As Long
Dim mrFormatDupKey1 As Range
Dim mrFormatDupKey2 As Range
Dim mrFormatMismatched As Range
Dim mrFormatMatched As Range
Dim mrFormatData1Only As Range
Dim mrFormatData2Only As Range
Dim msIgnoreCharacters As String
Dim msOnlyCharacters As String
Dim msaCompareWorkbooks() As String
'Dim msaCompareSheets() As String
Dim msCompareSheets As String
Dim msResultsSheet As String
Dim msErrorSheet As String
Dim msaHeadings1() As String
Dim msaHeadings2() As String
Dim msaHeadingRows() As String
Dim msaResultsSheets(1 To 6) As String
Dim mvaDuplicateKeys As Variant
Dim mwbOld As Workbook
Dim mwbNew As Workbook
Dim mwsReportSheet As Worksheet
Dim mwsErrorSheet As Worksheet
Dim mwsaResultsSheets(1 To 6) As Worksheet
Sub CompareSheets()
Dim bChanged As Boolean
Dim baChanged() As Boolean
Dim bIgnoreChanged As Boolean
Dim baIgnoreChanged() As Boolean
Dim dblCompareValue1 As Double
Dim dblCompareValue2 As Double
Dim lColEnd As Long
Dim lCol As Long
Dim lCol1 As Long
Dim lCol2 As Long
Dim lSheetPtr As Long
Dim lSheetPointer1 As Long
Dim lSheetPointer2 As Long
Dim lRow1 As Long
Dim lRow2 As Long
Dim lHeadingRow1 As Long
Dim lHeadingRow2 As Long
Dim objDictOld As Object, objDictNew As Object
Dim rReportCells As Range
Dim sCompareString1 As String
Dim sCompareString2 As String
Dim saWorksheetsList1() As String
Dim saWorksheetsList2() As String
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
mlDuplicateKeysCount = 0
mlReportRow = 0
Application.ScreenUpdating = False
If GetParameters = False Then Exit Sub
mlErrorRow = 0
For lSheetPtr = 1 To UBound(mwsaResultsSheets)
Set mwsReportSheet = mwsaResultsSheets(lSheetPtr)
If Not (mwsReportSheet Is Nothing) Then
With mwsReportSheet.Cells
.ClearFormats
.ClearContents
End With
If mbDisplayOutputHeadings = True Then
ReDim vaHeadings(1 To 1, 1 To UBound(msaHeadings1) + 2)
For lCol = 0 To UBound(msaHeadings1)
If msaHeadings1(lCol) = msaHeadings2(lCol) Then
vaHeadings(1, lCol + 2) = msaHeadings1(lCol)
Else
vaHeadings(1, lCol + 2) = msaHeadings1(lCol) & " / " & msaHeadings2(lCol)
End If
Next lCol
mwsReportSheet.Range("A1", mwsReportSheet.Cells(1, UBound(vaHeadings, 2)).Address).Value = vaHeadings
mwsReportSheet.CustomProperties.Item(1).Value = 1
Else
mwsReportSheet.CustomProperties.Item(1).Value = 0
End If
End If
Next lSheetPtr
Set mwbOld = GetInputWorkBook(WBName:=msaCompareWorkbooks(0), _
WorkbookId:="1")
If mwbOld Is Nothing Then Exit Sub
Set mwbNew = GetInputWorkBook(WBName:=msaCompareWorkbooks(1), _
WorkbookId:="2")
If mwbNew Is Nothing Then
CloseWorkbooks WB1:=mwbOld, WB2:=mwbNew
Exit Sub
End If
'-- Store sheetnames to be compared into arrays saWorksheetsList1 and saWorksheetsList2 --
PrepareInputWSList WSList1:=saWorksheetsList1, _
WSList2:=saWorksheetsList2, _
WB1:=mwbOld, _
WB2:=mwbNew
lReportRow = 1
For lSheetPointer1 = LBound(saWorksheetsList1) To UBound(saWorksheetsList1)
If saWorksheetsList1(lSheetPointer1) <> "" And saWorksheetsList2(lSheetPointer1) <> "" Then
Set wsOld = GetWorksheet(WSName:=saWorksheetsList1(lSheetPointer1), WB:=mwbOld)
Set wsNew = GetWorksheet(WSName:=saWorksheetsList2(lSheetPointer1), WB:=mwbNew)
If wsOld Is Nothing _
And wsNew Is Nothing Then
'-------------------------------
'-- Report invalid sheet names --
'-------------------------------
ReportDataError ErrorMessage:="Invalid Sheet name " & saWorksheetsList1(lSheetPointer1) _
& "/" _
& saWorksheetsList2(lSheetPointer1)
ElseIf wsNew Is Nothing Then
'-----------------------------------
'-- Report WB2 sheet not compared --
'-----------------------------------
Set wsReport = Nothing
Set wsReport = ThisWorkbook.Sheets(mwsaResultsSheets(mlResultsPtrData1Only).Name)
lReportRow = GetNextReportRow(WS:=mwsReportSheet, _
IncrementBefore:=1, _
IncrementAfter:=1)
Set rReportCells = wsReport.Range("A" & lReportRow)
rReportCells.Value = "Sheet '" & wsOld.Name & "' is unique to Workbook 1 (" & mwbOld.Name & ")"
mrFormatData1Only.Copy
rReportCells.PasteSpecial xlPasteFormats
ElseIf wsOld Is Nothing Then
'-----------------------------------
'-- Report WB1 sheet not compared --
'-----------------------------------
Set wsReport = Nothing
Set wsReport = ThisWorkbook.Sheets(mwsaResultsSheets(mlResultsPtrData2Only).Name)
lReportRow = GetNextReportRow(WS:=mwsReportSheet, _
IncrementBefore:=1, _
IncrementAfter:=1)
Set rReportCells = wsReport.Range("A" & lReportRow)
rReportCells.Value = "Sheet '" & wsNew.Name & "' is unique to Workbook 2 (" & mwbNew.Name & ")"
mrFormatData1Only.Copy
rReportCells.PasteSpecial xlPasteFormats
' ReportDataError ErrorMessage:="Sheet '" & saWorksheetsList1(lSheetPointer1) & "' not compared"
Else
'----------------------------
'-- Compare the two sheets --
'----------------------------
InitialReportSheetData WS1:=wsOld, _
WS2:=wsNew, _
ReportSheetsArray:=mwsaResultsSheets
lHeadingRow1 = Val(msaHeadingRows(0))
If lHeadingRow1 < 1 Then lHeadingRow1 = 1
lHeadingRow2 = Val(msaHeadingRows(UBound(msaHeadingRows)))
If lHeadingRow2 < 1 Then lHeadingRow2 = 1
If PopulateHeadingColumns(WS:=wsOld, _
HeadingsTexts:=msaHeadings1, _
HeadingsColumns:=miaHeadingCols1, _
HeadingRow:=lHeadingRow1, _
KeyColumns:=miaKeyFields1) = False Then
CloseWorkbooks WB1:=mwbOld, WB2:=mwbNew
Exit Sub
End If
Set mwsReportSheet = mwsaResultsSheets(mlResultsPtrDupKey1)
miMaxColumns = UBound(msaHeadings1) + 1
Set objDictOld = PopulateDictionary(WS:=wsOld, _
KeyColumns:=miaKeyFields1, _
HeadingRow:=lHeadingRow1, _
ReportSheet:=mwsReportSheet, _
ColumnPositions:=miaHeadingCols1, _
DupFormatRange:=mrFormatDupKey1)
If objDictOld Is Nothing Then
CloseWorkbooks WB1:=mwbOld, WB2:=mwbNew
Exit Sub
End If
If PopulateHeadingColumns(WS:=wsNew, _
HeadingsTexts:=msaHeadings2, _
HeadingsColumns:=miaHeadingCols2, _
HeadingRow:=lHeadingRow2, _
KeyColumns:=miaKeyFields2) = False Then
CloseWorkbooks WB1:=mwbOld, WB2:=mwbNew
Exit Sub
End If
Set mwsReportSheet = mwsaResultsSheets(mlResultsPtrDupKey2)
Set objDictNew = PopulateDictionary(WS:=wsNew, _
KeyColumns:=miaKeyFields2, _
HeadingRow:=lHeadingRow2, _
ReportSheet:=mwsReportSheet, _
ColumnPositions:=miaHeadingCols2, _
DupFormatRange:=mrFormatDupKey2)
If objDictNew Is Nothing Then
CloseWorkbooks WB1:=mwbOld, WB2:=mwbNew
Exit Sub
End If
vKeys = objDictOld.Keys
For Each vKey In vKeys
ReDim vaInputOld(1 To 1, 1 To miMaxColumns + 1)
vaInputOld = objDictOld.Item(vKey)
If objDictNew.Exists(vKey) Then
ReDim vaInputNew(1 To 1, 1 To miMaxColumns + 1)
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)
ReDim baIgnoreChanged(1 To miMaxColumns + 1)
bChanged = False
For lCol = 1 To miMaxColumns
vaOutput(1, lCol + 1) = vaInputOld(1, lCol)
With WorksheetFunction
If .IsNumber(vaInputOld(1, lCol)) _
And .IsNumber(vaInputNew(1, lCol)) Then
'-- If both fields numeric, check for tolerences --
dblCompareValue1 = .RoundDown(CDbl(vaInputOld(1, lCol)), mlRounding)
dblCompareValue2 = .RoundDown(CDbl(vaInputNew(1, lCol)), mlRounding)
dblCompareValue1 = Abs(dblCompareValue1 - dblCompareValue2)
sCompareString1 = Val(dblCompareValue1)
sCompareString2 = Val(dblCompareValue2)
If dblCompareValue1 <= mdblTolerance Then
'-- If within tolerence, set both fields the same --
sCompareString1 = sCompareString2
End If
Else
sCompareString1 = AdjustStringForComparison(InputString:=vaInputOld(1, lCol))
sCompareString2 = AdjustStringForComparison(InputString:=vaInputNew(1, lCol))
End If
End With
baIgnoreChanged(lCol) = CStr(LCase$(vaInputOld(1, lCol))) <> CStr(LCase$(vaInputNew(1, lCol)))
bIgnoreChanged = bIgnoreChanged Or baIgnoreChanged(lCol)
If sCompareString1 <> sCompareString2 Then
vaOutput2(1, lCol + 1) = vaInputNew(1, lCol)
If mbaHeadingsInfo(lCol - 1) = False Then
baChanged(lCol) = True
bChanged = True
End If
Else
If mbShowUnchangedCells = True Then
vaOutput2(1, lCol + 1) = vaInputNew(1, lCol)
End If
End If
Next lCol
If bChanged Then
Set mwsReportSheet = mwsaResultsSheets(mlResultsPtrMismatched)
If Not (mwsReportSheet Is Nothing) Then
mlReportRow = GetNextReportRow(WS:=mwsReportSheet, IncrementBefore:=0)
mrFormatMismatched.Copy
For lCol = 1 To UBound(baChanged)
If baChanged(lCol) Then
With mwsReportSheet
.Range(.Cells(mlReportRow, lCol + 1).Address, _
.Cells(mlReportRow + 1, lCol + 1).Address).PasteSpecial xlPasteFormats
End With
End If
Next lCol
vaOutput(1, 1) = "Changed: Row " & vaInputOld(1, UBound(vaInputOld, 2))
vaOutput2(1, 1) = "_______: Row " & vaInputNew(1, UBound(vaInputNew, 2))
With mwsReportSheet
.Range(.Cells(mlReportRow, 1).Address, _
.Cells(mlReportRow, miMaxColumns + 1).Address).Value = vaOutput
mlReportRow = mlReportRow + 1
.Range(.Cells(mlReportRow, 1).Address, _
.Cells(mlReportRow, miMaxColumns + 1).Address).Value = vaOutput2
End With
mwsReportSheet.CustomProperties.Item(1).Value = mlReportRow
End If 'If Not (mwsReportSheet Is Nothing) Then
Else 'If bChanged Then
Set mwsReportSheet = mwsaResultsSheets(mlResultsPtrMatched)
If Not (mwsReportSheet Is Nothing) Then
mlReportRow = GetNextReportRow(WS:=mwsReportSheet, IncrementBefore:=1)
vaOutput(1, 1) = "No Change: Row " & vaInputOld(1, UBound(vaInputOld, 2)) & _
", Row " & vaInputNew(1, UBound(vaInputNew, 2))
mrFormatMatched.Copy
With mwsReportSheet
With .Range(.Cells(mlReportRow, 1).Address, _
.Cells(mlReportRow, miMaxColumns + 1).Address)
.Value = vaOutput
.PasteSpecial xlPasteFormats
End With
End With
End If
End If 'If bChanged Then
objDictOld.Remove vKey
objDictNew.Remove vKey
Else 'If objDictNew.Exists(vKey) Then
Set mwsReportSheet = mwsaResultsSheets(mlResultsPtrData1Only)
If Not (mwsReportSheet Is Nothing) Then
mlReportRow = GetNextReportRow(WS:=mwsReportSheet, IncrementBefore:=1)
' mlReportRow = mwsReportSheet.CustomProperties.Item(1)
' mlReportRow = mlReportRow + 1
' mwsReportSheet.CustomProperties.Item(1).Value = mlReportRow
ReDim vaOutput(1 To 1, 1 To miMaxColumns + 1)
vaOutput(1, 1) = "Only Workbook 1 sheet " & saWorksheetsList1(lSheetPointer1) & " Row " & vaInputOld(1, UBound(vaInputOld, 2))
For lCol = 1 To miMaxColumns
vaOutput(1, lCol + 1) = vaInputOld(1, lCol)
Next lCol
With mwsReportSheet
.Range(.Cells(mlReportRow, 1).Address, .Cells(mlReportRow, miMaxColumns + 1).Address).Value = vaOutput
'-- Set the row format
mrFormatData1Only.Copy
.Range(.Cells(mlReportRow, 2).Address, .Cells(mlReportRow, miMaxColumns + 1).Address) _
.PasteSpecial xlPasteFormats
End With
End If
End If 'If objDictNew.Exists(vKey) Then
Next vKey
If objDictNew.Count <> 0 Then
vKeys = objDictNew.Keys
For Each vKey In vKeys
Set mwsReportSheet = mwsaResultsSheets(mlResultsPtrData2Only)
If Not (mwsReportSheet Is Nothing) Then
mlReportRow = GetNextReportRow(WS:=mwsReportSheet, IncrementBefore:=1)
ReDim vaOutput2(1 To 1, 1 To miMaxColumns + 1)
vaInputNew = objDictNew.Item(vKey)
vaOutput2(1, 1) = "Only Workbook 2 Sheet " & saWorksheetsList2(lSheetPointer1) & " Row " & vaInputNew(1, UBound(vaInputNew, 2))
For lCol = 1 To miMaxColumns
vaOutput2(1, lCol + 1) = vaInputNew(1, lCol)
Next lCol
With mwsReportSheet
.Range(.Cells(mlReportRow, 1).Address, .Cells(mlReportRow, miMaxColumns + 1).Address).Value = vaOutput2
'-- Set the row format
mrFormatData2Only.Copy
.Range(.Cells(mlReportRow, 2).Address, .Cells(mlReportRow, miMaxColumns + 1).Address) _
.PasteSpecial xlPasteFormats
' .Range(.Cells(mlReportRow, 2).Address, .Cells(mlReportRow, miMaxColumns + 1).Address).Interior.ColorIndex = 4
End With
End If
Next vKey
End If 'If objDictNew.Count <> 0 Then
End If 'If bSheet2Found = False Then ... Else
End If 'If saWorksheetsList1(lSheetPointer1) <> "" And saWorksheetsList2(lSheetPointer1) <> "" Then
Next lSheetPointer1
On Error Resume Next
CloseWorkbooks WB1:=mwbOld, WB2:=mwbNew
For lPtr = 1 To UBound(mwsaResultsSheets)
Set mwsReportSheet = mwsaResultsSheets(lPtr)
SetResultsSheetColumnWidths WS:=mwsReportSheet
Set mwsReportSheet = Nothing
Next lPtr
Set mwsErrorSheet = Nothing
objDictOld.RemoveAll
Set objDictOld = Nothing
objDictNew.RemoveAll
Set objDictNew = Nothing
End Sub
Private Function AdjustNumericValue(ByVal Valuex As Double) As String
AdjustNumericValue = CStr(WorksheetFunction.RoundDown(Valuex, mlRounding))
End Function
Private Sub ReportDataError(ByVal ErrorMessage As String)
If Not (mwsErrorSheet Is Nothing) Then
On Error GoTo 0
mlErrorRow = GetNextReportRow(WS:=mwsErrorSheet, IncrementBefore:=1)
mwsErrorSheet.Range("A" & mlErrorRow).Value = ErrorMessage
End If
End Sub
Private Sub InitialReportSheetData(ByVal WS1 As Worksheet, _
ByVal WS2 As Worksheet, _
ByRef ReportSheetsArray() As Worksheet)
Dim bDuplicate As Boolean
Dim lPtr As Long
Dim lPtr1 As Long
Dim lRow As Long
Dim sMessage As String
Dim vaData As Variant
Dim wsCurReportSheet As Worksheet
sMessage = "<<< Comparing '" & WS1.Parent.Name & "!" & WS1.Name & _
"' and '" & _
WS2.Parent.Name & "!" & WS2.Name & "' >>>"
ReDim vaData(1 To 2, 1 To 1)
vaData(1, 1) = sMessage
vaData(2, 1) = " "
For lPtr = LBound(ReportSheetsArray) To UBound(ReportSheetsArray)
Set wsCurReportSheet = ReportSheetsArray(lPtr)
bDuplicate = False
For lPtr1 = LBound(ReportSheetsArray) To lPtr - 1
If ReportSheetsArray(lPtr).Name = ReportSheetsArray(lPtr1).Name Then
bDuplicate = True
Exit For
End If
Next lPtr1
If bDuplicate = False Then
lRow = GetNextReportRow(WS:=wsCurReportSheet, IncrementBefore:=2, IncrementAfter:=1)
With wsCurReportSheet.Range("A" & lRow).Resize(UBound(vaData, 1))
.Value = vaData
.Font.Bold = True
.Font.Underline = xlUnderlineStyleSingle
End With
End If
Next lPtr
End Sub
Private Sub CloseWorkbooks(ByRef WB1 As Workbook, ByRef WB2 As Workbook)
On Error Resume Next
WB1.Close savechanges:=False
WB2.Close savechanges:=False
End Sub
Private Function GetInputWorkBook(ByVal WBName As String, _
ByVal WorkbookId As String) As Workbook
Dim lWBSheetPtr As Long
Dim lErrorNumber As Long
Dim sWBName As String
Dim sErrorDescription As String
Dim vFileToOpen As Variant
sWBName = Trim$(WBName)
If sWBName = "" Then sWBName = "Prompt"
If LCase$(sWBName) = "prompt" Then
vFileToOpen = Application.GetOpenFilename(filefilter:="Excel Files (*.xls*),*.xls*", _
Title:="Please select input workbook " & WorkbookId, _
MultiSelect:=False)
If vFileToOpen <> False Then
sWBName = vFileToOpen
End If
End If
If sWBName = Replace(sWBName, "\", "") Then
sWBName = ThisWorkbook.Path & "\" & sWBName
End If
On Error Resume Next
Set GetInputWorkBook = Nothing
Set GetInputWorkBook = Workbooks.Open(Filename:=sWBName, ReadOnly:=True)
lErrorNumber = Err.Number
sErrorDescription = Err.Description
On Error GoTo 0
If GetInputWorkBook Is Nothing Then
ReportDataError ErrorMessage:="Error " & lErrorNumber & " opening '" & sWBName & "' :- " & sErrorDescription
MsgBox prompt:=sErrorDescription, _
Buttons:=vbCritical + vbOKOnly, _
Title:="Error " & lErrorNumber & " opening " & sWBName
End If
End Function
Private Sub PrepareInputWSList(ByRef WSList1() As String, _
ByRef WSList2() As String, _
ByRef WB1 As Workbook, _
ByRef WB2 As Workbook)
'------------------------------------------------------------
'-- Return list of sheet pairings into WSList1 and WSList2 --
'------------------------------------------------------------
Dim bWanted As Boolean
Dim bFound As Boolean
Dim lPtr As Long
Dim lPtr1 As Long
Dim lPtr2 As Long
Dim lWSPtr As Long
Dim lUbound As Long
Dim saSheetNames() As String
Dim saSheetPairs() As String
Dim sCurName1 As String
Dim saWSNames() As String
Dim wsCur As Worksheet
ReDim WSList1(0 To 0)
ReDim WSList2(0 To 0)
lPtr1 = -1
lPtr2 = -1
msCompareSheets = WorksheetFunction.Trim(msCompareSheets)
If msCompareSheets = "" Then msCompareSheets = "All Sheets"
If LCase$(Left$(msCompareSheets, 10)) = "not sheets" Then
'-- Replace the "[" delimiter of the "Not Sheets" with a comma and remove the "]" --
'-- This will make the remaining parameters in line with the other formats --
msCompareSheets = Replace(msCompareSheets, "[", ",")
msCompareSheets = Replace(msCompareSheets, "]", "")
End If
If LCase$(Left$(msCompareSheets, 10)) = "all sheets" Then
'-- Here if all sheets to be compared --
ReDim WSList1(0 To WB1.Sheets.Count - 1)
ReDim WSList2(0 To WB1.Sheets.Count - 1)
For Each wsCur In WB1.Worksheets
sCurName1 = wsCur.Name
lPtr1 = lPtr1 + 1
WSList1(lPtr1) = sCurName1
WSList2(lPtr1) = sCurName1
Next wsCur
For Each wsCur In WB2.Worksheets
bFound = FindEntryInList(wsCur.Name, WSList1) > -1
If bFound Then
lUbound = UBound(WSList1) + 1
ReDim Preserve WSList1(0 To lUbound)
ReDim Preserve WSList2(0 To lUbound)
WSList1(lUbound) = wsCur.Name
WSList2(lUbound) = wsCur.Name
End If
Next wsCur
ElseIf LCase$(Left$(msCompareSheets, 10)) = "not sheets" Then
'-- here if 'Not Sheets[xx,yy,zz]' format --
saWSNames = Split("," & Replace(Replace(msCompareSheets, "(", ","), ")", ""), ",")
saWSNames(1) = ""
lWSPtr = -1
For Each wsCur In WB1.Worksheets
sCurName1 = LCase$(wsCur.Name)
bWanted = FindEntryInList(sCurName1, saWSNames) < 0
If bWanted Then
lUbound = UBound(WSList1) + 1
ReDim Preserve WSList1(0 To lUbound)
ReDim Preserve WSList2(0 To lUbound)
WSList1(lUbound) = wsCur.Name
WSList2(lUbound) = wsCur.Name
End If
Next wsCur
For Each wsCur In WB2.Worksheets
sCurName1 = LCase$(wsCur.Name)
bFound = FindEntryInList(sCurName1, WSList1) <> -1
If bFound = False Then
bWanted = FindEntryInList(sCurName1, saWSNames) < 0
If bWanted Then
lUbound = UBound(WSList1) + 1
ReDim Preserve WSList1(0 To lUbound)
ReDim Preserve WSList2(0 To lUbound)
WSList1(lUbound) = wsCur.Name
WSList2(lUbound) = wsCur.Name
End If
End If
Next wsCur
Else
saSheetNames = Split(msCompareSheets, ",")
ReDim WSList1(0 To UBound(saSheetNames))
ReDim WSList2(0 To UBound(saSheetNames))
For lPtr = 0 To UBound(saSheetNames)
saSheetPairs = Split("=" & Trim$(saSheetNames(lPtr)), "=")
ReDim Preserve saSheetPairs(0 To 2)
If saSheetPairs(2) = "" Then saSheetPairs(2) = saSheetPairs(1)
WSList1(lPtr) = Trim$(saSheetPairs(1))
WSList2(lPtr) = Trim$(saSheetPairs(2))
Next lPtr
End If
End Sub
Private Function FindEntryInList(ByVal Entry As String, ByRef List() As String) As Long
'-------------------------------------------------------------
'-- Return pointer to entry being searched. -1 if not found --
'-------------------------------------------------------------
Dim lPtr As Long
Dim sEntry As String
sEntry = Trim$(LCase$(Entry))
FindEntryInList = -1
For lPtr = LBound(List) To UBound(List)
If sEntry = Trim$(LCase$(List(lPtr))) Then
FindEntryInList = lPtr
Exit For
End If
Next lPtr
End Function
Private Sub SetResultsSheetColumnWidths(ByVal WS As Worksheet)
Dim lEndCol As Long
Dim saColumns() As String
On Error GoTo 0
If WS Is Nothing Then
Else
WS.Calculate
WS.Columns("A:A").ColumnWidth = 30
lEndCol = WS.UsedRange.Columns.Count
saColumns = Split(WS.Cells(1, lEndCol).Address(True, True), "$")
WS.Columns("B:" & saColumns(1)).EntireColumn.AutoFit
End If
End Sub
Private Function AdjustStringForComparison(ByVal InputString As String) As String
Dim lPtr As Long
Dim sChar As String
Dim sResult As String
If mbIgnoreCase = True Then
InputString = LCase$(InputString)
End If
If Len(msOnlyCharacters) = 0 Then
sResult = InputString
Else
If mbIgnoreCase = True Then
msOnlyCharacters = LCase$(msOnlyCharacters)
End If
For lPtr = 1 To Len(InputString)
sChar = Mid$(InputString, lPtr, 1)
If InStr(msOnlyCharacters, sChar) > 0 Then
sResult = sResult & sChar
End If
Next lPtr
End If
If Len(msIgnoreCharacters) > 0 Then
If mbIgnoreCase = True Then
msIgnoreCharacters = LCase$(msIgnoreCharacters)
End If
For lPtr = 1 To Len(msIgnoreCharacters)
sChar = Mid$(msIgnoreCharacters, lPtr, 1)
sResult = Replace(sResult, sChar, "")
Next lPtr
End If
AdjustStringForComparison = sResult
End Function
Private Function GetResultsWorksheet(ByVal WSName As String) As Worksheet
Dim lSheetsCount As Long
Dim sWSNumber As String
If Replace(LCase$(WSName), " ", "") = "<<no>>" Then
Set GetResultsWorksheet = Nothing
Else
On Error Resume Next
Set GetResultsWorksheet = ThisWorkbook.Sheets(WSName)
On Error GoTo 0
If (GetResultsWorksheet Is Nothing) Then
lSheetsCount = ThisWorkbook.Sheets.Count
With ThisWorkbook
lSheetsCount = .Sheets.Count
Set GetResultsWorksheet = .Sheets.Add(after:=.Sheets(lSheetsCount))
End With
On Error Resume Next
Err.Number = 0
GetResultsWorksheet.Name = WSName
If Err.Number > 0 Then
ReportDataError ErrorMessage:="Invalid sheet name '" & WSName & _
"'. Data being sent to sheet '" & _
GetResultsWorksheet.Name & "'"
MsgBox prompt:="Invalid sheet name '" & WSName & "'. Data being sent to sheet '" & _
GetResultsWorksheet.Name & "'", _
Buttons:=vbOKOnly + vbExclamation
End If
End If
If Not (GetResultsWorksheet Is Nothing) Then
On Error Resume Next
With GetResultsWorksheet.CustomProperties
.Item(1).Value = 0
.Add Name:="LastRowUsed", Value:=0
End With
With GetResultsWorksheet.Cells
.ClearFormats
.ClearContents
End With
End If
End If
End Function
'Private Sub ReportDataError(ByVal ErrorMessage As String)
'Const sDefaultSheetName As String = "Errors"
'
'If mwsErrorSheet Is Nothing Then
' If msErrorSheet = "" Then msErrorSheet = sDefaultSheetName
' On Error Resume Next
' Set mwsErrorSheet = Sheets(msErrorSheet)
' If mwsErrorSheet Is Nothing Then
' Set mwsErrorSheet = ThisWorkbook.Sheets.Add(after:=ThisWorkbook.Sheets(1))
' mwsErrorSheet.Name = msErrorSheet
' If Err.Number <> 0 Then mwsErrorSheet.Name = sDefaultSheetName
' End If
' With mwsErrorSheet.Cells
' .ClearFormats
' .ClearContents
' End With
' With mwsErrorSheet.CustomProperties
' .Item(1).Value = 0
' .Add Name:="LastRowUsed", Value:=0
' End With
'End If
'On Error GoTo 0
'
'mlErrorRow = GetNextReportRow(WS:=mwsErrorSheet, IncrementBefore:=1)
'mwsErrorSheet.Range("A" & mlErrorRow).Value = ErrorMessage
'End Sub
Private Function GetWorksheet(ByVal WSName As String, ByRef WB As Workbook) As Worksheet
Set GetWorksheet = Nothing
On Error Resume Next
Set GetWorksheet = WB.Sheets(WSName)
End Function
Private Function PopulateDictionary(ByRef WS As Worksheet, _
ByRef KeyColumns() As Integer, _
ByVal HeadingRow As Long, _
ByVal ReportSheet As Worksheet, _
ByRef ColumnPositions() As Integer, _
ByRef DupFormatRange As Range) 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 lReportPtr As Long
Dim lErrorNumber As Long
Dim rCur As Range
Dim sErrorDescription As String
Dim sKey As String
Dim sCurKey As String
Dim sText As String
Dim saCurKey() As String
Dim vaItem() As Variant
Dim vaCurRow As Variant
Dim vaReport As Variant
Dim vReply As Variant
ReDim saCurKey(LBound(KeyColumns) To UBound(KeyColumns))
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 = HeadingRow + 1 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
saCurKey(iKeyColsPtr) = CStr(vaCurRow(1, iKeyPtr))
sCurKey = LCase$(CStr(vaCurRow(1, iKeyPtr)))
If mbFilterKey = True Then
sCurKey = AdjustStringForComparison(sCurKey)
End If
sKey = sKey & "|" & sCurKey
End If
Next iKeyColsPtr
If sKey = "" Then
ReportDataError ErrorMessage:="Parameter error - No key headings specified"
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) + 2)
For iPtr = 0 To UBound(ColumnPositions)
iCurCol = ColumnPositions(iPtr)
vaItem(1, iPtr + 1) = vaCurRow(1, iCurCol)
Next iPtr
vaItem(1, UBound(vaItem, 2)) = lRow '-- Add row number to last element --
If PopulateDictionary.Exists(sKey) Then
If Not (ReportSheet Is Nothing) Then
lDuplicateCount = lDuplicateCount + 1
sText = "Duplicate key at row " & lRow & " of " & WS.Parent.Name & "!" & WS.Name & "."
ReDim vaReport(1 To 1, 1 To UBound(vaItem, 2))
vaReport(1, 1) = sText
For lReportPtr = 1 To UBound(vaReport, 2) - 1
vaReport(1, lReportPtr + 1) = vaItem(1, lReportPtr)
Next lReportPtr
mlReportRow = GetNextReportRow(WS:=ReportSheet, IncrementBefore:=1)
DupFormatRange.Copy
With ReportSheet.Range("A" & mlReportRow).Resize(, UBound(vaReport, 2))
.Value = vaReport
.PasteSpecial xlPasteFormats
' .Characters.Font.Color = vbRed
End With
End If
Else
On Error Resume Next
PopulateDictionary.Add Key:=sKey, Item:=vaItem
lErrorNumber = Err.Number
sErrorDescription = Err.Description
If lErrorNumber <> 0 Then
ReportDataError ErrorMessage:="Error " & lErrorNumber & " in sheet " & WS.Name & " row " & lRow & _
": " & sErrorDescription
If MsgBox(prompt:="Error " & lErrorNumber & " in sheet " & WS.Name & " row " & lRow & vbCrLf & _
sErrorDescription & 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
End Function
Private Function GetParameters() As Boolean
Dim bError 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 lPtr As Long
Dim sChar As String
Dim sCurValue As String
Dim sCurKey As String
Dim saCurInput() As String
Dim saHeadings() As String, saHeadingsA() As String
Dim vaParameters As Variant
Dim vaArrayResultsParams As Variant
Dim wsParams As Worksheet, wsTemp As Worksheet
On Error Resume Next
For iPtr = 1 To UBound(mwsaResultsSheets)
Set mwsaResultsSheets(iPtr) = Nothing
Next iPtr
On Error GoTo 0
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
ReDim msaHeadingRows(0 To 0)
msaHeadingRows(0) = "1"
mbDisplayOutputHeadings = True
msErrorSheet = "Errors"
iParamCheck = 0
For lRow = 2 To UBound(vaParameters, 1)
sCurKey = NormaliseText(CStr(vaParameters(lRow, 1)))
Select Case sCurKey
Case "comparesheets"
msCompareSheets = Trim$(CStr(vaParameters(lRow, 2)))
If msCompareSheets = "" Then msCompareSheets = "*"
Case "compareworkbooks"
If Trim$(CStr(vaParameters(lRow, 2))) = "" Then
ReDim msaCompareWorkbooks(0 To 1)
Else
msaCompareWorkbooks = Split(CStr(vaParameters(lRow, 2)), ",")
'-- Dont bother error checking, just ensure exactly 2 elements --
ReDim Preserve msaCompareWorkbooks(0 To 1)
End If
Case "displayoutputheadings"
Select Case LCase$(CStr(vaParameters(lRow, 2)))
Case "yes"
mbDisplayOutputHeadings = True
Case "no"
mbDisplayOutputHeadings = False
Case Else
MsgBox prompt:="'Display Output Headings' parameter not 'Yes' or 'No'", Buttons:=vbOKOnly + vbCritical
GetParameters = False
Exit Function
End Select
Case "errorsheet"
sCurValue = Trim$(CStr(vaParameters(lRow, 2)))
If Replace(LCase$(sCurValue), " ", "") = "<<no>>" Then
msErrorSheet = sCurValue
Else
msErrorSheet = ""
For lPtr = 1 To Len(sCurValue)
sChar = Mid$(sCurValue, lPtr, 1)
If InStr("abcdefghijklmnopqrstuvwxyz 0123456789", LCase$(sChar)) > 0 Then
msErrorSheet = msErrorSheet & sChar
End If
Next lPtr
msErrorSheet = Trim$(msErrorSheet)
If msErrorSheet = "" Then msErrorSheet = "Errors"
End If
Case "filterkey"
Select Case LCase$(CStr(vaParameters(lRow, 2)))
Case "yes"
mbFilterKey = True
Case "no"
mbFilterKey = False
Case Else
MsgBox prompt:="'Filter Key' parameter not 'Yes' or 'No'", Buttons:=vbOKOnly + vbCritical
GetParameters = False
Exit Function
End Select
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 "headingsrow"
msaHeadingRows = Split(CStr(vaParameters(lRow, 2)), ",")
Case "ignorecase"
Select Case LCase$(CStr(vaParameters(lRow, 2)))
Case "yes"
mbIgnoreCase = True
Case "no"
mbIgnoreCase = False
Case Else
MsgBox prompt:="'Ignore Case' parameter not 'Yes' or 'No'", Buttons:=vbOKOnly + vbCritical
GetParameters = False
Exit Function
End Select
Case "ignorecharacters"
msIgnoreCharacters = CStr(vaParameters(lRow, 2))
Case "onlycharacters"
msOnlyCharacters = CStr(vaParameters(lRow, 2))
Case "resultssheetdata1only"
Set mwsaResultsSheets(mlResultsPtrData1Only) = GetResultsWorksheet(WSName:=CStr(vaParameters(lRow, 2)))
Set mrFormatData1Only = wsParams.Range("B" & lRow)
Case "resultssheetdata2only"
Set mwsaResultsSheets(mlResultsPtrData2Only) = GetResultsWorksheet(WSName:=CStr(vaParameters(lRow, 2)))
Set mrFormatData2Only = wsParams.Range("B" & lRow)
Case "resultssheetduplicatekeydata1"
Set mwsaResultsSheets(mlResultsPtrDupKey1) = GetResultsWorksheet(WSName:=CStr(vaParameters(lRow, 2)))
Set mrFormatDupKey1 = wsParams.Range("B" & lRow)
Case "resultssheetduplicatekeydata2"
Set mwsaResultsSheets(mlResultsPtrDupKey2) = GetResultsWorksheet(WSName:=CStr(vaParameters(lRow, 2)))
Set mrFormatDupKey2 = wsParams.Range("B" & lRow)
Case "resultssheetmatched"
Set mwsaResultsSheets(mlResultsPtrMatched) = GetResultsWorksheet(WSName:=CStr(vaParameters(lRow, 2)))
Set mrFormatMatched = wsParams.Range("B" & lRow)
Case "resultssheetmismatched"
Set mwsaResultsSheets(mlResultsPtrMismatched) = GetResultsWorksheet(WSName:=CStr(vaParameters(lRow, 2)))
Set mrFormatMismatched = wsParams.Range("B" & lRow)
Case "rounding"
mlRounding = Val(vaParameters(lRow, 2))
Case "showunchangedcells"
Select Case LCase$(CStr(vaParameters(lRow, 2)))
Case "yes"
mbShowUnchangedCells = True
Case "no"
mbShowUnchangedCells = False
Case Else
MsgBox prompt:="'Show Unchanged Cells' parameter not 'Yes' or 'No'", Buttons:=vbOKOnly + vbCritical
GetParameters = False
Exit Function
End Select
Case "tolerance"
mdblTolerance = Abs(Val(vaParameters(lRow, 2)))
Case Else
MsgBox prompt:="Unrecognised parameter in row " & lRow, Buttons:=vbOKOnly + vbCritical
GetParameters = False
Exit Function
End Select
Next lRow
On Error Resume Next
Set mwsErrorSheet = GetResultsWorksheet(WSName:=msErrorSheet)
mwsErrorSheet.Range("A1").Value = "No Errors Reported"
GetParameters = True
End Function
Public Function StartsWith(str As String, prefix As String) As Boolean
StartsWith = Left(str, Len(prefix)) = prefix
End Function
Private Function GetNextReportRow(ByRef WS As Worksheet, _
Optional IncrementBefore As Long = 0, _
Optional IncrementAfter As Long = 0) As Long
Dim lRow As Long
lRow = WS.CustomProperties.Item(1).Value
WS.CustomProperties.Item(1).Value = lRow + IncrementBefore + IncrementAfter
GetNextReportRow = lRow + IncrementBefore
End Function
Private Function PopulateHeadingColumns(ByVal WS As Worksheet, _
ByRef HeadingsTexts() As String, _
ByRef HeadingsColumns() As Integer, _
ByVal HeadingRow As Long, _
ByRef KeyColumns() As Integer) As Boolean
Dim bFound As Boolean
Dim iPtrCol As Integer
Dim iPtrHeading As Integer
Dim iColEnd As Integer
Dim sCurHeading As String
Dim sCur As String
Dim sMessage As String
Dim vaHeadings() As Variant
iColEnd = WS.Cells(HeadingRow, Columns.Count).End(xlToLeft).Column
vaHeadings = WS.Range("A" & HeadingRow & ":" & WS.Cells(HeadingRow, 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
sMessage = "Heading '" & HeadingsTexts(iPtrHeading) & _
"' not found in workbook '" & WS.Parent.Name & "' sheet '" & WS.Name & "'"
ReportDataError ErrorMessage:=sMessage
MsgBox prompt:=sMessage, _
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
