'------------------------------------------------------------------+ ' Module specification '------------------------------------------------------------------+ ' ' Module Name : CompareWorksheets ' ' Copyright : Yokogawa SCE, 2004 ' ' Author : Jan Worst ' ' Description : Compare Worksheets ' '------------------------------------------------------------------+ ' Changes .... '------------------------------------------------------------------+ ' Who When Change What '------------------------------------------------------------------+ ' WST Jun-04 exxxx FAST/TOOLS to Excel demo '------------------------------------------------------------------+ ' ' Compare Worksheets ws1 and ws2' Place results in ws1 ' ws1 and ws2 must both contain table key (column "NAME") Public Const CLR_FONT_DIFFERS = 3 ' red Public Const CLR_FILL_DIFFERS = 40 ' light red Public Const CLR_FILL_EXCEL_ONLY = 36 ' light yellow Public Const CLR_FILL_FT_ONLY = 37 ' light blue Public Const CLR_FONT_NOT_IN_WS2 = 48 ' gray Option Explicit Public Sub CompareWorksheets( _ ws1 As Worksheet, ws1Name As String, _ ws2 As Worksheet, ws2Name As String) ' Debug.Print "qldCompareWorksheets - ws1=" & ws1.Name & ", ws2 = " & ws2.Name; "" Dim rowWs1 As Long Dim rowWs2 As Long ' Dim row As Long Dim colWs1 As Long Dim colWs2 As Long Dim ws1ColCount As Integer ' ws1 column count Dim ws2ColCount As Integer ' ws2 column count Dim ws1ColComment As Integer ' ws1 Comment column Dim ws2ColComment As Integer ' ws2 Comment column ' Dim ws1ColName As Integer ' column containing key (field "NAME") ' Dim ws2ColName As Integer ' column containing key (field "NAME") ' Dim ws1RowCount As Long 'Dim ws2RowCount As Long Dim ws1Keys(1 To 66000) As String Dim ws2Keys(1 To 66000) As String Dim CountUnequal As Long Dim countOnlyWs1 As Long Dim countOnlyWs2 As Long Dim ws1RowHeader As Long Dim ws2RowHeader As Long Dim ws1RowFirst As Long Dim ws2RowFirst As Long Dim ws1RowLast As Long Dim ws2RowLast As Long Dim qldWS1 As New qldWorkSheet qldWS1.Initialize ws1 ws1ColCount = qldWS1.ColumnCount ws1RowHeader = qldWS1.RowDataHeader ws1RowFirst = qldWS1.RowDataFirst ws1RowLast = qldWS1.RowDataLast Dim qldWS2 As New qldWorkSheet qldWS2.Initialize ws2 ws2ColCount = qldWS2.ColumnCount ws2RowHeader = qldWS2.RowDataHeader ws2RowFirst = qldWS2.RowDataFirst ws2RowLast = qldWS2.RowDataLast '------------------------------------------------------ ' Fill key array ws1 and ws2 '------------------------------------------------------ If FillKeyArray(ws1Keys, qldWS1, ws1ColComment) = False Then Exit Sub If FillKeyArray(ws2Keys, qldWS2, ws2ColComment) = False Then Exit Sub '------------------------------------------------------ ' Compare all cells in Excel with FT table '------------------------------------------------------ Dim ColFound As Boolean Dim KeyFound As Boolean Dim Equal As Boolean ' Dim Key As String For rowWs1 = ws1RowFirst To ws1RowLast ' Debug.Print rowWs1 & " " & ws1.Cells(rowWs1, ws1ColName) ' Find row in temporary sheet KeyFound = False ' Key = ws1.Cells(rowWs1, ws1ColName) For rowWs2 = ws2RowFirst To ws2RowLast If ws1Keys(rowWs1) = ws2Keys(rowWs2) Then KeyFound = True ' Debug.Print "Found : " & rowWs1 & " " & ws1.Cells(rowWs1, ws1ColName) ' Compare cells Equal = True For colWs1 = 1 To ws1ColCount ColFound = False For colWs2 = 1 To ws2ColCount If ws1.Cells(ws1RowHeader, colWs1) = ws2.Cells(ws1RowHeader, colWs2) Then If ws1.Cells(rowWs1, colWs1) <> ws2.Cells(rowWs2, colWs2) Then On Error Resume Next ' Ignore existing comment ws1.Cells(rowWs1, colWs1).ClearComments ws1.Cells(rowWs1, colWs1).AddComment On Error GoTo 0 With ws1.Cells(rowWs1, colWs1).Comment .Text Text:=ws2Name & ": " & ws2.Cells(rowWs2, colWs2) .Visible = False .Shape.ScaleHeight 0.2, msoFalse, msoScaleFromTopLeft .Shape.ScaleWidth 4, msoFalse, msoScaleFromTopLeft End With ws1.Cells(rowWs1, colWs1).Font.ColorIndex = CLR_FONT_DIFFERS ws1.Cells(rowWs1, colWs1).Font.Bold = True Equal = False CountUnequal = CountUnequal + 1 End If ColFound = True Exit For End If Next colWs2 If ColFound = False Then ' Column not found in ws2 ws1.Cells(rowWs1, colWs1).Font.ColorIndex = CLR_FONT_NOT_IN_WS2 End If Next colWs1 If Not Equal Then For colWs1 = 1 To ws1ColCount ws1.Cells(rowWs1, colWs1).Interior.ColorIndex = CLR_FILL_DIFFERS Next colWs1 End If End If If KeyFound Then Exit For Next rowWs2 If Not KeyFound Then For colWs1 = 1 To ws1ColCount ws1.Cells(rowWs1, colWs1).Interior.ColorIndex = CLR_FILL_EXCEL_ONLY Next colWs1 ws1.Cells(rowWs1, ws1ColComment).AddComment With ws1.Cells(rowWs1, ws1ColComment).Comment ' .Text Text:="Record not in FAST/TOOLS table" .Text Text:="Record not in " & ws2Name .Visible = False .Shape.ScaleHeight 0.2, msoFalse, msoScaleFromTopLeft .Shape.ScaleWidth 1.5, msoFalse, msoScaleFromTopLeft End With countOnlyWs1 = countOnlyWs1 + 1 End If Next rowWs1 '------------------------------------------------------ ' Add all records that only exist in FT/ws2 to compare sheet ws1 '------------------------------------------------------ For rowWs2 = ws2RowFirst To ws2RowLast KeyFound = False For rowWs1 = ws1RowFirst To ws1RowLast If ws2Keys(rowWs2) = ws1Keys(rowWs1) Then KeyFound = True Exit For End If Next rowWs1 If Not KeyFound Then countOnlyWs2 = countOnlyWs2 + 1 ' Append row ws2 to ws1 For colWs1 = 1 To ws1ColCount ws1.Cells(ws1RowLast + countOnlyWs2, colWs1) = ws2.Cells(rowWs2, colWs1) ' ws1.Cells(ws1RowLast + countOnlyWs2, colWs1).Errors.Item(xlNumberAsText).Ignore = True ws1.Cells(ws1RowLast + countOnlyWs2, colWs1).Interior.ColorIndex = CLR_FILL_FT_ONLY Next colWs1 ws1.Cells(ws1RowLast + countOnlyWs2, ws1ColComment).AddComment With ws1.Cells(ws1RowLast + countOnlyWs2, ws1ColComment).Comment .Text Text:="Record not in " & ws1Name .Visible = False .Shape.ScaleHeight 0.2, msoFalse, msoScaleFromTopLeft .Shape.ScaleWidth 1.5, msoFalse, msoScaleFromTopLeft End With End If Next rowWs2 '------------------------------------------------------ ' Report differences '------------------------------------------------------ Dim s As String If CountUnequal + countOnlyWs1 + countOnlyWs2 = 0 Then s = "Excel and FAST/TOOLS table are equal" Else s = "" If CountUnequal Then s = s & CountUnequal & " records not equal " & vbCrLf If countOnlyWs1 Then s = s & countOnlyWs1 & " records in " & ws1Name & " only" & vbCrLf If countOnlyWs2 Then s = s & countOnlyWs2 & " records in " & ws2Name & " only " & vbCrLf End If MsgBox s, vbInformation, "Differences" Set qldWS1 = Nothing Set qldWS2 = Nothing End Sub '-------------------------------------------------------------------- ' ' Fill key array with "NAME" field, or with INSTALL/UNIT/TAG fields ' ' Returns column where "compare-comment " should be written '-------------------------------------------------------------------- Private Function FillKeyArray( _ wsKeys() As String, _ qldws As qldWorkSheet, _ ByRef ColComment As Integer) As Boolean Dim ColName As Integer Dim ws As Worksheet '------------------------------------------ ' Find columns containing key fields '------------------------------------------ Set ws = qldws.Worksheet ColName = qldws.ColFieldName("NAME") '------------------------------------------ ' Find columns containing key fields '------------------------------------------ If ColName > 0 Then ColComment = ColName Else Select Case qldws.DatasetName Case "INSTALL_DF": ColComment = qldws.ColFieldName("INSTALL") Case "UNIT_DF": ColComment = qldws.ColFieldName("UNIT") Case "ITEM_DF", "ITEM_VAL", "OBJECT_DF": ColComment = qldws.ColFieldName("TAG") Case "SUB_ITEM_DF": ColComment = qldws.ColFieldName("SUB") Case "ITEM_HIS_DF": ColComment = qldws.ColFieldName("TAG") Case Else MsgBox "column NAME missing", vbExclamation Exit Function End Select End If '------------------------------------------ ' Fill keys string array '------------------------------------------ Dim Row As Long FillKeyArray = False ' assume error For Row = qldws.RowDataFirst To qldws.RowDataLast wsKeys(Row) = qldws.getKeyValue(Row) Next Row FillKeyArray = True Exit Function KeyError: MsgBox Err.Number & ": " & Err.Description, vbCritical FillKeyArray = False End Function 用VS编写C#程序