Comparing Workbooks
How to Compare 2 workbooks ?
This procedure creates a new workbook which lists the comparison results for each worksheet in the two workbooks of interest.
Both the workbooks should be open prior to running this procedure.
Sub DoCompare()
Dim WS As Worksheet
Workbooks.Add
For Each WS In WorkBooks("BetterSolutions_1.xls").Worksheets
Call CompareWorkbooks(WS, Workbooks("BetterSolutions_2.xls").Worksheets(WS.Name))
Next
End Sub
Sub CompareWorkbooks(ByVal WS1 As Worksheet, _
ByVal WS2 As Worksheet)
Dim iRow As Integer,
Dim iCol As Integer
Dim R1 As Range,
Dim R2 As Range
Worksheets.Add.Name = WS1.Name ' new book for the results
Range("A1:D1").Value = Array("Address", "Difference", WS1.Parent.Name, WS2.Parent.Name)
Range("A2").Select
For iRow = 1 To Application.Max(WS1.Range("A1").SpecialCells(xlLastCell).Row, _
WS2.Range("A1").SpecialCells(xlLastCell).Row)
For iCol = 1 To Application.Max(WS1.Range("A1").SpecialCells(xlLastCell).Column, _
WS2.Range("A1").SpecialCells(xlLastCell).Column)
Set R1 = WS1.Cells(iRow, iCol)
Set R2 = WS2.Cells(iRow, iCol)
' compare the types to avoid getting VBA type mismatch errors.
If TypeName(R1.Value) <> TypeName(R2.Value) Then
NoteError R1.Address, "Type", R1.Value, R2.Value
ElseIf R1.Value <> R2.Value Then
If TypeName(R1.Value) = "Double" Then
If Abs(R1.Value - R2.Value) > R1.Value * 10 ^ (-12) Then
NoteError R1.Address, "Double", R1.Value, R2.Value
End If
Else
NoteError R1.Address, "Value", R1.Value, R2.Value
End If
End If
' record formulae without leading "=" to avoid them being evaluated
If R1.HasFormula Then
If R2.HasFormula Then
If R1.Formula <> R2.Formula Then
NoteError R1.Address, "Formula", Mid(R1.Formula, 2), Mid(R2.Formula, 2)
End If
Else
NoteError R1.Address, "Formula", Mid(R1.Formula, 2), "**no formula**"
End If
Else
If R2.HasFormula Then
NoteError R1.Address, "Formula", "**no formula**", Mid(R2.Formula, 2)
End If
End If
If R1.NumberFormat <> R2.NumberFormat Then
NoteError R1.Address, "NumberFormat", R1.NumberFormat, R2.NumberFormat
End If
Next iCol
Next iRow
With ActiveSheet.UsedRange.Columns
.AutoFit
.HorizontalAlignment = xlLeft
End With
End Sub
Sub NoteError(Address As String, What As String, V1, V2)
ActiveCell.Resize(1, 4).Value = Array(Address, What, V1, V2)
ActiveCell.Offset(1, 0).Select
If ActiveCell.Row = Rows.Count Then
MsgBox "Too many differences", vbExclamation
End
End If
End Sub
© 2023 Better Solutions Limited. All Rights Reserved. © 2023 Better Solutions Limited TopPrevNext