'------------------------------------------------------------------+
' 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#程序
本文介绍如何使用Visual Basic for Applications (VBA)创建一个宏，用于打开指定路径的Excel文件，并设置其为不可见状态。适用于需要自动化处理Excel文件场景。
扫一扫
3960
被折叠的 条评论
为什么被折叠?
到【灌水乐园】发言
