VBsS cmpare 2 Excel Files

Class clsComparer
 '[--- Region Private Variables Start ---]

 Private oExcel  'Excel.Application

 Private arrRangeUno 'Range.Value (array) of the Primary Excel spreadsheet

 Private arrRangeDos 'Range.Value (array) of the Secondary Excecl spreadsheet

 Private oDict  'Scripting.Dictionary containing unmatched cells

 '[--- Region Private Variables End ---]


 '[--- Region Public Variables Start ---]

 Public Operation '0: Only Compare   1: Compare & Highlight Differences

 '[--- Region Public Variables End ---]


 '--------------------------------------------------------
 ' Name: Function Compare [Public]
 '
 ' Remarks: N/A
 '
 ' Purpose: Compares differences between 2 Excel Spreadsheets
 ' 
 ' Arguments:
 ' sWorkBookUno: Primary Excel WorkBook (with complete path)
 ' vSheetUno: Primary Excel Spreadsheet Name
 ' sWorkBookDos: Secondary Excel WorkBook (with complete path)
 ' vSheetDos: Secondary Excel Spreadsheet Name
 '
 ' Return: Boolean
 '
 ' Author: Anshoo Arora, Relevant Codes
 '
 ' Date: 03/17/2010
 '
 ' References: N/A
 '--------------------------------------------------------
 Public Function Compare(sWorkBookUno, vSheetUno, sWorkBookDos, vSheetDos)
  Dim oWorkBookUno, oWorkBookDos

  'New instance of Excel
  Set Excel = CreateObject("Excel.Application")

  Compare = False
  
  'Open Primary WorkBook
  Set WorkBookUno = oExcel.WorkBooks.Open(sWorkBookUno)
  'Open Secondary WorkBook
  Set WorkBookDos = oExcel.WorkBooks.Open(sWorkBookDos)

  'Primary WorkBook Range
  arrRangeUno = oWorkBookUno.WorkSheets(vSheetUno).UsedRange.Value
  'Secondary WorkBook Range
  arrRangeDos = oWorkBookDos.WorkSheets(vSheetDos).UsedRange.Value

  'Check using CellsFound (see below) and determine any unmatched cells
  If Not CellsFound > 0 Then Compare = True

  'If peration = 0, function only runs a comparison
  'If peration = 1, function runs a comparison and highlights differences
  If Not Compare Then
   If peration = 1 Then
    Dim Keys, oSheetUno, oSheetDos, iRow, iCol

    Keys = oDict.Keys

    Set SheetUno = oWorkBookUno.WorkSheets(vSheetUno)
    Set SheetDos = oWorkBookDos.WorkSheets(vSheetDos)

    'Highlight each Row/Column combination from the dictionary
    For Each iKey in Keys
     iRow = CInt(Split(iKey, "|")(0))
     iCol = CInt(Split(iKey, "|")(1))

     'Highlight the difference in the Primary Sheet
     oSheetUno.Rows(iRow).Columns(iCol).Interior.ColorIndex = 3
     'Highlight the difference in the Secondary Sheet
     oSheetDos.Rows(iRow).Columns(iCol).Interior.ColorIndex = 3
    Next

    'Save primary and secondary workbooks
    oWorkBookUno.Save
    oWorkBookDos.Save

    'Dispose primary and secondary sheet objects
    Set SheetUno = Nothing
    Set SheetDos = Nothing
   End If
  End If

  'Dispose primary and secondary workbook objects
  oWorkBookUno.Close
  oWorkBookDos.Close
 End Function

 '--------------------------------------------------------
 ' Name: Function CellsFound [Private]
 '
 ' Remarks: N/A
 '
 ' Purpose: Finds the dissimilar cells between 2 sheets
 ' 
 ' Arguments: N/a
 '
 ' Return: Integer
 '
 ' Author: Anshoo Arora, Relevant Codes
 '
 ' Date: 03/17/2010
 '
 ' References: N/A
 '--------------------------------------------------------
 Private Function CellsFound()
  Dim iBoundsUno, iBoundsDos, iCellUno, iCellDos

  CellsFound = 0

  'New instance of Scripting.Dictionary
  Set Dict = CreateObject("Scripting.Dictionary")

  'Get 2D upper bound for Primary Range
  iBoundsUno = UBound(arrRangeUno, 2)
  'Get 2D upper bound for Secondary Range
  iBoundsDos = UBound(arrRangeDos, 2)

  'If Range are not equal..
  If iBoundsUno <> iBoundsDos Then
   Reporter.ReportEvent micWarning, "Compare", "Unequal Range."
  End If

  'Build a Dictionary with all unmatched cells [Private oDict]
  For iCellUno = 1 to UBound(arrRangeUno, 1)
   For iCellDos = 1 to UBound(arrRangeUno, 2)
    If arrRangeUno(iCellUno, iCellDos) <> arrRangeDos(iCellUno, iCellDos) Then
     oDict.Add iCellUno & "|" & iCellDos, ""
    End If
   Next
  Next

  'Total dissimilar cells equal CellsFound
  CellsFound = oDict.Count
 End Function

 '--------------------------------------------------------
 ' Name: Sub Class_Terminate [Private]
 '
 ' Remarks: N/A
 '
 ' Purpose: Disposes the Excel.Application object
 ' 
 ' Arguments: N/A
 '
 ' Author: Anshoo Arora, Relevant Codes
 '
 ' Date: 03/17/2010
 '
 ' References: N/A
 '--------------------------------------------------------
 Private Sub Class_Terminate()
  If IsObject(oExcel) Then
   If Not oExcel Is Nothing Then
    Set Excel = Nothing
   End If
  End If
  
  If TypeName(oDict) = "Dictionary" Then
   Set Dict = Nothing
  End If
 End Sub

End Class

'--------------------------------------------------------
' Name: Function CompareExcelSheets
'
' Remarks: N/A
'
' Purpose: Constructor for Class clsComparer
' 
' Arguments:
' sWorkBookUno: Primary Excel WorkBook (with complete path)
' vSheetUno: Primary Excel Spreadsheet Name
' sWorkBookDos: Secondary Excel WorkBook (with complete path)
' vSheetDos: Secondary Excel Spreadsheet Name
' Operation: 0: Compare Only   1: Compare & Highlight Differences
'
' Return: Boolean
'
' Author: Anshoo Arora, Relevant Codes
'
' Date: 03/17/2010
'
' References: N/A
'--------------------------------------------------------
Function CompareExcelSheets(sWorkBookUno, vSheetUno, sWorkBookDos, vSheetDos, Operation)
 Dim oClass

 Set Class = New clsComparer
 oClass.Operation = Operation

 CompareExcelSheets = oClass.Compare(sWorkBookUno, vSheetUno, sWorkBookDos, vSheetDos)

 Set Class = Nothing
End Function