比较行和报告差异Excel VBA [英] Comparing rows and reporting back diferences Excel VBA

问题描述

我一直在尝试使用以下代码来比较两个Excel工作表，但是我无法按照我的需要使其正常工作。我需要逐行比较并报告具体差异，即使每张表上的数据行不一定是相同的顺序。代码根据表中数据的物理存在方式报告所有差异。所以它显示出差异，但是如果数据在每个表中按照相同的顺序，它们实际上不会是差异。由于数据的本质，我无法排序。希望这是有道理的。有人可以提出需要什么改变才能得到我需要的东西？

I've been trying to use the following code to compare two Excel sheets however I can't get it to function quite as I need. I need to compare row by row and report specific differences even when rows of data on each sheet are not necessarily in the same order. The code reports all differences based on how the data physically exists in the tables. So it is showing differences but if the data was put into the same order in each table they wouldn't actually be differences. Due to the nature of the data I can't sort first. Hope this makes sense. Could someone please suggest what changes are required to get what I need?

Sub Compare()
    ' compare two different worksheets in the active workbook
    CompareWorksheets Worksheets("Sheet1"), Worksheets("Sheet2")
    ' compare two different worksheets in two different workbooks
    'CompareWorksheets ActiveWorkbook.Worksheets("Sheet1"), _
       ' Workbooks("impchk1.xls").Worksheets("Sheet2")
End Sub

Sub CompareWorksheets(ws1 As Worksheet, ws2 As Worksheet)
Dim r As Long, c As Integer
Dim lr1 As Long, lr2 As Long, lc1 As Integer, lc2 As Integer
Dim maxR As Long, maxC As Integer, cf1 As String, cf2 As String
Dim rptWB As Workbook, DiffCount As Long
    Application.ScreenUpdating = False
    Application.StatusBar = "Creating the report..."
    Set rptWB = Workbooks.Add
    Application.DisplayAlerts = False
    While Worksheets.Count > 1
        Worksheets(2).Delete
    Wend
    Application.DisplayAlerts = True
    With ws1.UsedRange
        lr1 = .Rows.Count
        lc1 = .Columns.Count
    End With
    With ws2.UsedRange
        lr2 = .Rows.Count
        lc2 = .Columns.Count
    End With
    maxR = lr1
    maxC = lc1
    If maxR < lr2 Then maxR = lr2
    If maxC < lc2 Then maxC = lc2
    DiffCount = 0
    For c = 1 To maxC
        Application.StatusBar = "Comparing cells " & Format(c / maxC, "0 %") & "..."
        For r = 1 To maxR
            cf1 = ""
            cf2 = ""
            On Error Resume Next
            cf1 = ws1.Cells(r, c).FormulaLocal
            cf2 = ws2.Cells(r, c).FormulaLocal
            On Error GoTo 0
            If cf1 <> cf2 Then
                DiffCount = DiffCount + 1
                Cells(r, c).Formula = "'" & cf1 & " <> " & cf2
            End If
        Next r
    Next c
    Application.StatusBar = "Formatting the report..."
    With Range(Cells(1, 1), Cells(maxR, maxC))
        .Interior.ColorIndex = 19
        With .Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .Weight = xlHairline
        End With
        With .Borders(xlEdgeRight)
            .LineStyle = xlContinuous
            .Weight = xlHairline
        End With
        With .Borders(xlEdgeLeft)
            .LineStyle = xlContinuous
            .Weight = xlHairline
        End With
        With .Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .Weight = xlHairline
        End With
        On Error Resume Next
        With .Borders(xlInsideHorizontal)
            .LineStyle = xlContinuous
            .Weight = xlHairline
        End With
        With .Borders(xlInsideVertical)
            .LineStyle = xlContinuous
            .Weight = xlHairline
        End With
        On Error GoTo 0
    End With
    Columns("A:IV").ColumnWidth = 20
    rptWB.Saved = True
    If DiffCount = 0 Then
        rptWB.Close False
    End If
    Set rptWB = Nothing
    Application.StatusBar = False
    Application.ScreenUpdating = True
    MsgBox DiffCount & " cells contain different formulas!", vbInformation, _
        "Compare " & ws1.Name & " with " & ws2.Name
End Sub

推荐答案

将更新的工作表，将每行转换为字符串并将其保存到字典。然后，在工作表中，您正在更新，循环遍历所有行，获取其字符串代码，并查看它是否存在于字典中。如果没有，请添加它们。

In the worksheet that will be updated, convert each row to a string and save it to a dictionary. Then, in the worksheet you're updating from, loop through all the rows, get their string rep and see if it exists in the dictionary. If it doesn't, then add them.

这是一个从行值获取字符串的示例代码

Here's an example code that gets a string from a rows values

Sub getRowAsString()
    Dim cell As Object
    Dim sheet As Worksheet
    Dim str As String
    Dim arr() As Variant
    Dim arr2() As Variant
    Dim printCol As Integer

    Set sheet = ActiveSheet
    printCol = sheet.UsedRange.Columns.Count + 1

    For Each cell In sheet.UsedRange.Rows
        arr = cell.Value2
        ReDim arr2(LBound(arr, 2) To UBound(arr, 2))

        For i = LBound(arr, 2) To UBound(arr, 2)
            arr2(i) = arr(1, i)
        Next i

        str = Join(arr2, ", ")
        ActiveSheet.Cells(cell.Row, printCol).value = str
    Next cell
End Sub

以下是使用字典的示例：

Here's an example of using a dictionary:

Sub createDictionary()
    Dim dict As Object
    Set dict = CreateObject("Scripting.Dictionary")

    Key = "hello"
    value = "world"
    dict.Add Key, value

    MsgBox "key exists: " & dict.exists(Key) & vbNewLine & "value: " & dict(Key)
End Sub

如果一行的字符串表示太大，您可以将其哈希值保存到字典中，使其更易于管理。 这里是提供VBA代码的帖子用于散列字符串

If the string representation of a row is too large, you can save a hashed value of it into the dictionary to make it more manageable. Here is a post that gives VBA code for hashing a string

这篇关于比较行和报告差异Excel VBA的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！