用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