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