用VBS比较两个Excel文件的数据

 

relevantcodes.com的一篇文章《VBScript: Compare 2 Excel Files》中介绍了如何用VBScript来比较两个Excel文件的数据：

http://relevantcodes.com/vbscript-compare-2-excel-files/

 

主要是使用了Excel的COM接口的range对象来实现的。支持比较数据并且高亮显示差异：

 

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 oExcel = CreateObject("Excel.Application")

 

              Compare = False

             

              'Open Primary WorkBook

              Set oWorkBookUno = oExcel.WorkBooks.Open(sWorkBookUno)

              'Open Secondary WorkBook

              Set oWorkBookDos = 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 Operation = 0, function only runs a comparison

              'If Operation = 1, function runs a comparison and highlights differences

              If Not Compare Then

                     If Operation = 1 Then

                            Dim Keys, oSheetUno, oSheetDos, iRow, iCol

 

                            Keys = oDict.Keys

 

                            Set oSheetUno = oWorkBookUno.WorkSheets(vSheetUno)

                            Set oSheetDos = 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 oSheetUno = Nothing

                            Set oSheetDos = 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 oDict = 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 oExcel = Nothing

                     End If

              End If

             

              If TypeName(oDict) = "Dictionary" Then

                     Set oDict = 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 oClass = New clsComparer

       oClass.Operation = Operation

 

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

 

       Set oClass = Nothing

End Function