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



© 2019 Better Solutions Limited. All Rights Reserved. © 2019 Better Solutions Limited TopPrevNext