' begin code
Dim wkbLog As Excel.Workbook
Dim iLogPos1 As Long, iLogPos2 As Long, iLogPos3 As Long, iLogPos4 As Long, iLogPos5 As Long
Private Sub LogSheetChange(s As String)
iLogPos1 = iLogPos1 + 1
wkbLog.Worksheets(1).Cells(iLogPos1, 1).Value = s
End Sub
Private Sub LogRowChange(s As String)
iLogPos2 = iLogPos2 + 1
wkbLog.Worksheets(2).Cells(iLogPos2, 1).Value = s
End Sub
Private Sub logValueChange(sSheet As String, sRange As String, sVal1 As String, sVal2 As String)
iLogPos3 = iLogPos3 + 1
With wkbLog.Worksheets(3)
.Cells(iLogPos3, 1).Value = sSheet
.Cells(iLogPos3, 2).Value = sRange
.Cells(iLogPos3, 3).Value = sVal1
.Cells(iLogPos3, 4).Value = sVal2
End With
End Sub
Private Sub logFormulaChange(sSheet As String, sRange As String, sVal1 As String, sVal2 As String)
iLogPos4 = iLogPos4 + 1
With wkbLog.Worksheets(4)
.Cells(iLogPos4, 1).Value = sSheet
.Cells(iLogPos4, 2).Value = sRange
.Cells(iLogPos4, 3).Value = "'" & sVal1
.Cells(iLogPos4, 4).Value = "'" & sVal2
End With
End Sub
Public Sub logError(sSheet As String, sRange As String, sVal1 As String, sVal2 As String, sProblem As String)
iLogPos5 = iLogPos5 + 1
With wkbLog.Worksheets(5)
.Cells(iLogPos5, 1).Value = sSheet
.Cells(iLogPos5, 2).Value = sRange
.Cells(iLogPos5, 3).Value = "'" & sVal1
.Cells(iLogPos5, 4).Value = "'" & sVal2
.Cells(iLogPos5, 5).Value = sProblem
End With
End Sub
Public Sub CompareWorkbooks()
Dim sPath1 As String
Dim sPath2 As String
With Application.FileDialog(msoFileDialogOpen)
.AllowMultiSelect = False
.Title = "Select Original File"
If .Show Then
sPath1 = .SelectedItems(1)
Else
Exit Sub
End If
.Title = "Select File to Compare"
If .Show Then
sPath2 = .SelectedItems(1)
Else
Exit Sub
End If
End With
iLogPos1 = 1
iLogPos2 = 1
iLogPos3 = 1
iLogPos4 = 1
iLogPos5 = 1
If Not doCompare(sPath1, sPath2) Then
Call MsgBox("An error occurred = exiting.", vbOKOnly + vbCritical)
End If
End Sub
Private Function doCompare(sPath1 As String, sPath2 As String) As Boolean
Dim wkb1 As Excel.Workbook
Dim wkb2 As Excel.Workbook
Dim calcs As Excel.XlCalculation
On Error Resume Next
Set wkb1 = Application.Workbooks.Open(sPath1, ReadOnly:=False, UpdateLinks:=False)
On Error GoTo 0
If wkb1 Is Nothing Then
doCompare = False
Call MsgBox("Could not open " & sPath1, vbOKOnly + vbExclamation)
Exit Function
End If
On Error Resume Next
Set wkb2 = Application.Workbooks.Open(sPath2, ReadOnly:=True, UpdateLinks:=False)
On Error GoTo 0
If wkb2 Is Nothing Then
doCompare = False
Call MsgBox("Could not open " & sPath2, vbOKOnly + vbExclamation)
Exit Function
End If
Set wkbLog = Application.Workbooks.Add
Dim i As Long
For i = 1 To 5 - wkbLog.Worksheets.Count
wkbLog.Worksheets.Add
Next i
wkbLog.Worksheets(1).Name = "Sheet Changes"
wkbLog.Worksheets(2).Name = "Range Changes"
wkbLog.Worksheets(3).Name = "Value Changes"
wkbLog.Worksheets(4).Name = "Formula Changes"
wkbLog.Worksheets(5).Name = "Formula Errors"
Application.DisplayAlerts = False
Application.ScreenUpdating = False
calcs = Application.Calculation
Application.Calculation = xlCalculationManual
CheckSheets wkb1, wkb2
wkbLog.SaveAs Filename:=wkb1.Name & " comparison log " & Format(Now(), "yyyy-mm-dd") & ".xlsx", FileFormat:=xlWorkbookNormal
'wkb1.SaveAs Filename:="Comparison of " & wkb1.Name
wkb1.Close False
wkb2.Close False
Application.StatusBar = False
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.Calculation = calcs
doCompare = True
End Function
Private Function CheckSheets(ByRef wkb1 As Excel.Workbook, ByRef wkb2 As Excel.Workbook) As Boolean
Dim wsh1 As Excel.Worksheet, wsh2 As Excel.Worksheet
Dim bFound As Boolean
Application.StatusBar = "Checking Worksheets"
LogSheetChange ""
LogSheetChange "Checking worksheets in " & wkb1.Name & " against " & wkb2.Name
' check missing wsh2
For Each wsh1 In wkb1.Worksheets
Set wsh2 = Nothing
Application.StatusBar = "Checking Worksheets - " & wsh1.Name
On Error Resume Next
Set wsh2 = wkb2.Worksheets(wsh1.Name)
On Error GoTo 0
If wsh2 Is Nothing Then
LogSheetChange wsh1.Name & " NOT FOUND in " & wkb2.Name
Else
LogRowChange ""
LogRowChange "Checking ranges in " & wsh1.Name
CheckRanges wsh1, wsh2
End If
Next wsh1
LogSheetChange ""
LogSheetChange "Checking for additional worksheets in " & wkb2.Name _
& " that are not in " & wkb1.Name
' check additional wsh1
For Each wsh2 In wkb2.Worksheets
bFound = False
Application.StatusBar = "Checking Worksheets - " & wsh2.Name
For Each wsh1 In wkb1.Worksheets
If StrComp(wsh2.Name, wsh1.Name) = 0 Then
bFound = True
Exit For
End If
Next wsh1
If Not bFound Then
LogSheetChange wsh2.Name & " has been added in " & wkb2.Name
End If
Next wsh2
CheckSheets = True
End Function
Private Function CheckRanges(ByRef wsh1 As Excel.Worksheet, ByRef wsh2 As Excel.Worksheet) As Boolean
Dim i1 As Long, i2 As Long
Dim iRows As Long, iCols As Long
LogRowChange ""
LogRowChange "Checking " & wsh1.Name & " rows and columns"
i1 = wsh1.UsedRange.Rows.Count
i2 = wsh2.UsedRange.Rows.Count
If i1 <> i2 Then
LogRowChange wsh1.Name & " in " & wsh1.Parent.Name & " has " & _
IIf(i1 < i2, " fewer ", " more ") & " rows than " & wsh2.Name & " in " & wsh2.Parent.Name
Else
LogRowChange wsh1.Name & " rows match"
End If
iRows = Application.WorksheetFunction.Max(i1, i2)
i1 = wsh1.UsedRange.Columns.Count
i2 = wsh2.UsedRange.Columns.Count
If i1 <> i2 Then
LogRowChange wsh1.Name & " in " & wsh1.Parent.Name & " has " & _
IIf(i1 < i2, " fewer ", " more ") & " columns than " & wsh2.Name & " in " & wsh2.Parent.Name
Else
LogRowChange wsh1.Name & " columns match"
End If
iCols = Application.WorksheetFunction.Max(i1, i2)
CheckData wsh1, wsh2, iRows, iCols
CheckRanges = True
End Function
Private Function CheckData(ByRef wsh1 As Excel.Worksheet, ByRef wsh2 As Excel.Worksheet, iRows As Long, iCols As Long) As Boolean
Dim r1 As Excel.Range, r2 As Excel.Range
Dim i As Long, j As Long
logValueChange "", "", "", ""
logValueChange wsh1.Name, "A1:" & wsh1.Cells(iRows, iCols).Address(False, False), wsh1.Parent.Name, wsh2.Parent.Name
logFormulaChange "", "", "", ""
logFormulaChange wsh1.Name, "A1:" & wsh1.Cells(iRows, iCols).Address(False, False), wsh1.Parent.Name, wsh2.Parent.Name
logError "", "", "", "", ""
logError wsh1.Name, "A1:" & wsh1.Cells(iRows, iCols).Address(False, False), wsh1.Parent.Name, wsh2.Parent.Name, ""
For i = 1 To iRows
For j = 1 To iCols
Set r1 = wsh1.Cells(i, j)
Set r2 = wsh2.Cells(i, j)
If r1.HasFormula And r2.HasFormula Then
If Not IsError(r1.Value) And Not IsError(r2.Value) Then
On Error Resume Next
If StrComp(r1.Formula, r2.Formula) <> 0 Then
logFormulaChange wsh1.Name, r1.Address, r1.Formula, r2.Formula
' With r1.Interior
' .Pattern = xlSolid
' .PatternColorIndex = xlAutomatic
' .Color = 65535
' End With
End If ' string compare
On Error GoTo 0
Else ' is error
logError wsh1.Name, r1.Address & " ERROR", r1.Formula, r2.Formula, r2.Text
End If
End If
On Error Resume Next:
If Len(r1.Value) > 0 Or Len(r2.Value) > 0 Then
If IsNumeric(r1.Value) And IsNumeric(r2.Value) Then
If r1.Value <> r2.Value Then
logValueChange wsh1.Name, r1.Address, "=" & r1.Address(True, True, xlA1, True), "=" & r2.Address(True, True, xlA1, True)
' With r1.Interior
' .Pattern = xlSolid
' .PatternColorIndex = xlAutomatic
' .Color = 65535
' End With
End If ' number compare
Else ' not isnumeric
If StrComp(r1.Value, r2.Value) <> 0 Then
logValueChange wsh1.Name, r1.Address, "=" & r1.Address(True, True, xlA1, True), "=" & r2.Address(True, True, xlA1, True)
' With r1.Interior
' .Pattern = xlSolid
' .PatternColorIndex = xlAutomatic
' .Color = 65535
' End With
End If ' string compare
End If ' numeric or string
End If
On Error GoTo 0
Next j
Next i
End Function
