比較同一工作簿中的兩張工作表

Question

想要比較同一工作簿中的兩個工作表並突出顯示兩個工作表中不同的每個單元格。 將此作為參考，以最快的方式比較 excel 中同一工作簿中的兩張工作表。 方法是將表放到 object 到字典到 object 到表。 當前將其修改為並能夠比較發生錯誤“438”的位置 object 在## If sMetric = dict(sKey) Then ## block while comparison 不支持此屬性或方法。 在調試模式下運行時，我能夠看到 sMetric 和 dict(sKey) 值。 但是 ws(2)(2,4) 行會引發此錯誤。 你能幫我修一下嗎？

考慮塊、模式、Fdy、A、B、C、D 作為兩個工作表中的標題，並且硬編碼 no_of_key_columns = 3 其中前 3 個被視為鍵，A、B、C、D 作為硬編碼為 no_data_Column = 的值4 可以在兩張表中取任何值進行比較，但盡量取幾個不同的值來查看比較。 我希望逐個單元格比較並突出顯示那些不同的單元格。 如果 sMetric = dict(sKey) 塊意味着只在值旁邊添加一個空格，這樣我就可以進行條件格式設置，以便為包含類似空格的紅色單元格着色。

Sub compare(Sheet1 As Worksheet, Sheet2 As Worksheet)
    Dim wb As Workbook
        Dim ws(2) As Worksheet, wsSum As Worksheet, wsCopy As Worksheet
        Dim rowCount(2) As Long, colCount(2) As Integer, colMetric(2) As Integer
        Dim colsMetric(2) As String, colsAll(2) As String, colsKeys(2) As String
        Dim bMetricsFlag As Boolean, bColCountFlag As Boolean, bColOrderFlag As Boolean
        Dim i As Long, ar, msg As String, intFalseCount As Long
     
        Dim t0 as Single
        t0 = Timer

    Set wb = ThisWorkbook
        Set ws(1) = Sheet1
        Set ws(2) = Sheet2
    Dim wsV(2) As Variant
    
    'get stats for each sheet 1-Pattern_Status 2=TSSDownloaded
        For i = 1 To 2
        with ws(i)
            wsV(i) = ws(i).Range(.Cells(1,1), .Cells(.UsedRange.Rows.Count, .UsedRange.Columns.Count))
        End With
            ar = Stats(ws(i))
            rowCount(i) = ar(0)
            colCount(i) = ar(1)
            colMetric(i) = ar(2)
            colsAll(i) = ar(3)
            colsMetric(i) = ar(4)
            colsKeys(i) = ar(5)
        Next

    ' check stats
        'Metric' column number must be same
    bMetricFlag = True

        If colCount(1) <> colCount(2) Then
            msg = "Metrics columns not the same or missing : " & vbCr & _
            "Pattern_Status : " & colCount(1) & vbCr & _
            "TSSDownloaded : " & colCount(2)
            MsgBox msg, vbCritical
            bcolCountFlag = False
        Else
            bcolCountFlag = True
        End If

    'Verify Order of columns
        If colsAll(1) <> colsAll(2) Then
            msg = "Column order not the same : " & vbCr & _
            "Pattern_status : " & colsAll(1) & vbCr & _
            "TSSDownloaded : " & colsAll(2)
            MsgBox msg, vbCritical
            bColOrderFlag = False
        Else
            bColOrderFlag = True
        End If

    ' checks OK ?
        If bColOrderFlag And bColCountFlag Then
         ' ok
        Else
            MsgBox "So Data Comparision can not be done", vbCritical
            Exit Sub
        End If

    ' start comparison
        Dim dict As Object, m As Long, c As Long, s As String
        Dim sKey As String, sMetric As String
        Set dict = CreateObject("Scripting.Dictionary")

    ' scan TSSDownloaded sheet to build dictionary
        no_of_key_columns = 3
    no_of_data_columns = 4
        For i = 1 To rowCount(2)
            sMetric = "": sKey = ""
            For c = 1 To colCount(2)
                    s = Trim(wsV(2)(i, c))
                    If c > no_of_key_columns Then
                        If sMetric <> "" Then sMetric = sMetric & "*"
                        sMetric = sMetric & s
                    ElseIf c <= no_of_key_columns Then
                If Not c > no_of_data_columns Then
                            If sKey <> "" Then sKey = sKey & "*"
                            sKey = sKey & s
                End If
                    End If
            Next
            dict(sKey) = sMetric
        Next

    ' scan Pattern_Status sheet to compare dictionary
        For i = 2 To rowCount(1)
            sMetric = "": sKey = ""
            For c = 1 To colCount(1)
                    s = Trim(wsV(1)(i, c))
                    If c > no_of_key_columns Then
                        If sMetric <> "" Then sMetric = sMetric & "*"
                        sMetric = sMetric & s
                    ElseIf c <= no_of_key_columns Then
                If Not c > no_of_data_columns Then
                            If sKey <> "" Then sKey = sKey & "*"
                            sKey = sKey & s
                End If
                    End If
            Next
    If sMetric = dict(sKey) Then            'Causing error from here. have a look at this block mainly.
        ws(2)(2,4) = ws(2)(2,4)
    Else
        ar(1) = Split(sMetric, "*")
        'Debug.print ar(1)
        ar(2) = Split(dict(sKey, "*"))
        For j = 0 to UBound(ar(2))
            If ar(1)(j) <> ar(2)(j) Then
                ws(2)(2,4+j) = ws(2)(2,4+j) & " "
            End If
            Next
    End If
    Sheet1 = ws(1)
    Sheet2 = ws(2) 'Object to sheet
    
    Next
    
    MsgBox i - 2 & " rows scanned " & vbCrLf & _
            intFalseCount & " FAILED", vbInformation, Int(Timer - t0) & "seconds"   

End sub

Answer 1

這對我來說是一個有趣的問題，我嘗試了一個可能更普遍的問題，它可能不完全符合您的要求，但我想我會分享這種方法。

在這種方法中，我為兩個Range對象創建了兩個大小相同的數組。 如果對象在兩張表中占據相同的相關區域，您應該能夠僅與 arrays 進行比較。 隨着大量項目的添加，字典往往會變慢，所以我認為這個解決方案有可能更快。 在我的機器上進行快速測試會在 ~0.5 秒內執行以下代碼。

該代碼僅在您的數據從 A1 開始並下降時才有效，盡管應該可以計算出使其更通用所需的偏移量。

看看，希望對你有幫助。

Option Explicit

'Run this sub
Public Sub RunMe()
    Dim t As Single: t = timer
    Dim rng1 As Range: Set rng1 = ThisWorkbook.Sheets(1).Range("A1:C500000")
    Dim rng2 As Range: Set rng2 = ThisWorkbook.Sheets(2).Range("A1:C500000")
    CompareRanges rng1, rng2
    Debug.Print timer - t & " seconds"
End Sub

Private Sub CompareRanges(rng1 As Range, rng2 As Range)
    Dim Rows    As Long
    Dim Columns As Long
    
    Rows = IIf(rng1.Rows.Count > rng2.Rows.Count, rng1.Rows.Count, rng2.Rows.Count)
    Columns = IIf(rng1.Columns.Count > rng2.Columns.Count, rng1.Columns.Count, rng2.Columns.Count)
    
    Dim Rng1Array As Variant: Rng1Array = SheetToArray(rng1.Parent, Rows, Columns)
    Dim Rng2Array As Variant: Rng2Array = SheetToArray(rng2.Parent, Rows, Columns)
    
    Dim i As Long
    Dim j As Long
    
    Dim rng1Sheet As Worksheet: Set rng1Sheet = rng1.Parent
    Dim rng2Sheet As Worksheet: Set rng2Sheet = rng2.Parent
    
    Dim ConditionalFormatRng1 As Range
    Dim ConditionalFormatRng2 As Range
    
    For i = LBound(Rng1Array, 2) To UBound(Rng1Array, 2)
        
        For j = LBound(Rng1Array, 1) To UBound(Rng1Array, 1)
            
            If Rng1Array(j, i) <> Rng2Array(j, i) Then
                
                If ConditionalFormatRng1 Is Nothing Then
                    Set ConditionalFormatRng1 = rng1Sheet.Cells(j, i)
                    Set ConditionalFormatRng2 = rng2Sheet.Cells(j, i)
                Else
                    Set ConditionalFormatRng1 = Union(rng1Sheet.Cells(j, i), ConditionalFormatRng1)
                    Set ConditionalFormatRng2 = Union(rng2Sheet.Cells(j, i), ConditionalFormatRng2)
                End If
                
            End If
            
        Next
        
    Next
   
    ConditionalFormatRng1.Interior.Color = vbRed
    ConditionalFormatRng2.Interior.Color = vbRed
    
End Sub

Private Function SheetToArray(Sheet As Worksheet, _
                              Rows As Long, _
                              Columns As Long) As Variant
                              
    With Sheet
       SheetToArray = .Range(.Cells(1, 1), .Cells(Rows, Columns)).Value2
    End With
End Function

Answer 2

也許這個。 兩種選擇。

Sub checkrev()

With Sheets("Sheet1")
Sh1LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
Set Sh1Range = .Range("A1:A" & Sh1LastRow)
End With
With Sheets("Sheet2")
Sh2LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
Set Sh2Range = .Range("A1:A" & Sh2LastRow)
End With

'compare sheet 1 with sheet 2
For Each Sh1cell In Sh1Range
Set c = Sh2Range.Find( _
what:=Sh1cell, LookIn:=xlValues)
If c Is Nothing Then
Sh1cell.Interior.ColorIndex = 3
Sh1cell.Offset(0, 1).Interior.ColorIndex = 3
Else
If Sh1cell.Offset(0, 1) <> c.Offset(0, 1) Then
Sh1cell.Interior.ColorIndex = 6
Sh1cell.Offset(0, 1).Interior.ColorIndex = 6
End If
End If
Next Sh1cell
'compare sheet 2 with sheet 1
For Each Sh2cell In Sh2Range
Set c = Sh1Range.Find( _
what:=Sh2cell, LookIn:=xlValues)
If c Is Nothing Then
Sh2cell.Interior.ColorIndex = 3
Sh2cell.Offset(0, 1).Interior.ColorIndex = 3
Else
If Sh2cell.Offset(0, 1) <> c.Offset(0, 1) Then
Sh2cell.Interior.ColorIndex = 6
Sh2cell.Offset(0, 1).Interior.ColorIndex = 6
End If
End If
Next Sh2cell

End Sub


Sub CheckRev_v2()
'====================
'Originating author: Joel from "microsoft.public.excel.programming" 10.09.07
'====================
Application.ScreenUpdating = False

With Sheets("Sheet1")
Sh1LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
Set Sh1Range = .Range("A1:A" & Sh1LastRow)
End With
With Sheets("Sheet2")
Sh2LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
Set Sh2Range = .Range("A1:A" & Sh2LastRow)
End With

'compare sheet 1 with sheet 2
For Each Sh1cell In Sh1Range
Set c = Sh2Range.Find( _
what:=Sh1cell, LookIn:=xlValues)
If c Is Nothing Then
Sh1cell.Offset(0, 2).Value = "No Match Found!"
Sh1cell.Offset(0, 2).Font.Color = -16776961
Sh1cell.Offset(0, 2).Font.Bold = True
'Sh1cell.Offset(0, 3).Value = Sh1cell.Offset(0, 1).Value 'enters Revlevel
Else
If Sh1cell.Offset(0, 1) <> c.Offset(0, 1) Then
Sh1cell.Offset(0, 2).Font.Italic = True
Sh1cell.Offset(0, 2).ColumnWidth = 25
Sh1cell.Offset(0, 2).Value = "Revision Level Change!"
End If
End If
Next Sh1cell
'compare sheet 2 with sheet 1
For Each Sh2cell In Sh2Range
Set c = Sh1Range.Find( _
what:=Sh2cell, LookIn:=xlValues)
If c Is Nothing Then
Sh2cell.Offset(0, 2).Value = "No Match Found!"
Sh2cell.Offset(0, 2).Font.Color = -16776961
Sh2cell.Offset(0, 2).Font.Bold = True
'Sh2cell.Offset(0, 3).Value = Sh2cell.Offset(0, 1).Value 'enters Revlevel
Else
If Sh2cell.Offset(0, 1) <> c.Offset(0, 1) Then
Sh2cell.Offset(0, 2).Font.Italic = True
Sh2cell.Offset(0, 2).ColumnWidth = 25
Sh2cell.Offset(0, 2).Value = "Revision Level Change!"
End If
End If
Next Sh2cell
Application.ScreenUpdating = True
End Sub

前：

后：