时间戳

首页 > 解决方案 > 比较表 1 中表 2 中缺失数据和新数据的两个 Excel 表

excel - 比较表 1 中表 2 中缺失数据和新数据的两个 Excel 表

问题描述

我有两张包含许多行和列的 Excel 工作表。表 1 是基线表，表 2 是新数据表。我想比较两个工作表并查看工作表 2 中缺少哪些数据以及工作表 2 中添加了哪些新数据。当在工作表 2 中添加/删除任何行时，这些行的值将不匹配。

作为第一步，我创建了一个宏来连接 Col A 到 E，并在两张纸上显示 Col H 中的结果。现在我需要在工作表 3 中创建一个宏，它将比较两个工作表中的 Col H，并将结果显示为缺失数据 (Sheet3:Col C) 和新数据 (Sheet3:Col D)。(Sheet3:Col A) 和 (Sheet3:Col B) 将分别是来自 Sheet 1 和 Sheet 2 的串联 COL H。我目前有一个宏，即使零件存在于表 1 中，它也会显示误报。

Sub MacroCompare()
'
' MacroCompare Macro
'

'
    Sheets("baseline").Select
    Range("H1").Select
    ActiveCell.FormulaR1C1 = "baseline"
    Columns("H:H").Select
    Selection.Copy
    Sheets("Comparison").Select
    Columns("A:A").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Sheets("baselinecopy").Select
    Columns("A:A").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Sheets("test").Select
    Range("H1").Select
    Application.CutCopyMode = False
    ActiveCell.FormulaR1C1 = "test"
    Columns("H:H").Select
    Selection.Copy
    Sheets("Comparison").Select
    Columns("B:B").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Sheets("testcopy").Select
    Columns("A:A").Select
    Range("A43").Activate
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Sheets("Comparison").Select
    Range("C1").Select
    Application.CutCopyMode = False
    ActiveCell.FormulaR1C1 = "missing"
    Range("D1").Select
    ActiveCell.FormulaR1C1 = "extras"
    Range("C2").Select
    ActiveCell.FormulaR1C1 = _
        "=VLOOKUP(baselinecopy!RC[-2],testcopy!R2C1:R7443C1,1,FALSE)"
    Range("C2").Select
    Selection.AutoFill Destination:=Range("C2:C7443")
    Range("C2:C7443").Select
    Range("D2").Select
    ActiveCell.FormulaR1C1 = _
        "=VLOOKUP(testcopy!RC[-3],baselinecopy!R2C1:R7443C1,1,FALSE)"
    Range("D2").Select
    Selection.AutoFill Destination:=Range("D2:D7443")
    Range("D2:D7443").Select
End Sub

标签： excelvbavlookupxlookup

解决方案

将连接的列作为键存储在Dictionary Object中。

Option Explicit

Sub MacroCompare()

    Const C = "~" ' concatenation character

    Dim wb As Workbook
    Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
    Dim iLastRow As Long, iCompare As Long
    Dim addCount As Long, deleteCount As Long
    Dim r As Long, i As Integer, s As String, ar

    Set wb = ThisWorkbook
    Set ws1 = wb.Sheets(1) ' baseline
    Set ws2 = wb.Sheets(2) ' test

    Dim dict, k
    Set dict = CreateObject("Scripting.Dictionary")
    
    ' scan baseline build dictionary
    iLastRow = ws1.Cells(Rows.Count, "A").End(xlUp).Row
    For r = 2 To iLastRow
        ' concatenate
        ar = ws1.Cells(r, "A").Resize(1, 5) ' A to E
        k = ar(1, 1)
        For i = 2 To UBound(ar, 2)
            k = k & C & ar(1, i)
        Next

        If dict.exists(k) Then
            MsgBox "Duplicate key '" & k & "'", vbCritical, "Error Row " & r
            Exit Sub
        Else
            dict.Add k, r
        End If
    Next

    ' scan test for items not in dictionary
    Set ws3 = wb.Sheets(3) ' compare
    ws3.Cells.Clear
    ws3.Range("A1:I1") = Array("Sht1", "Sht2", "A", "B", "C", "D", "E", "Del", "Add")
    iCompare = 1

    iLastRow = ws2.Cells(Rows.Count, "A").End(xlUp).Row
    For r = 2 To iLastRow
        ar = ws2.Cells(r, "A").Resize(1, 5) ' A to E
        k = ar(1, 1)
        For i = 2 To UBound(ar, 2)
            k = k & C & ar(1, i)
        Next
        
        If dict.exists(k) Then
            dict.Remove k
        Else
            iCompare = iCompare + 1
            ws3.Cells(iCompare, "B") = k '"Row " & r
            ws3.Cells(iCompare, "C").Resize(1, 5) = Split(k, C)
            ws3.Cells(iCompare, "I") = "Added"
            'ws2.Cells(r, "A").Interior.Color = vbGreen
            addCount = addCount + 1
        End If
    Next

    ' show deleted
    For Each k In dict
        r = dict(k)
        iCompare = iCompare + 1
        ws3.Cells(iCompare, "A") = k '"Row " & r
        ws3.Cells(iCompare, "C").Resize(1, 5) = Split(k, C)
        ws3.Cells(iCompare, "H") = "Deleted"
        'ws1.Cells(r, "A").Interior.Color = vbRed
        deleteCount = deleteCount + 1
    Next
 
   ' result
    s = "added = " & addCount & vbCrLf & _
        "deleted = " & deleteCount
    MsgBox s, vbInformation

End Sub

推荐阅读