vba - 比较 2 张纸中的数据并找出不匹配的地方

Question

我的工作簿中有 3 张工作表，其中 2 张包含类似的信息 - 相同的列，但数据可能会有所不同。

因此，在 A 列中有单位列表，然后在 B 列中有内容，在 C 列 - 温度，在 D 列 - 目的地。

我要做的是比较两张表中的数据以显示表 3 中的所有不匹配 - 即如果单元号 (A) 匹配，则查找内容 (B)、温度 (c) 和目的地 (D) 中的不匹配.如果其中任何数据不同，请将其从两张纸并排复制到第三张纸上。

然后，比较单位编号 - 如果在一张纸中找到编号但在另一张纸中没有找到编号，则以红色突出显示，如果两个列表中的数字匹配，则以黄色突出显示或保持颜色相同。

这是我到目前为止所得到的:

Option Explicit

Const MySheet1 As String = "Sheet1" 'list 1

Const MySheet2 As String = "Sheet2" 'list 2

Const MySheet3 As String = "Sheet3" 'output sheet

Sub CompareLists()

    Dim List1() As Variant, List2() As Variant
    Dim LC1 As Long, LC2 As Long, ORow As Long
    Dim Loop1 As Long, Loop2 As Long, Loop3 As Long

    ORow = 4
    With ThisWorkbook
        LC1 = .Sheets(MySheet1).UsedRange.Rows.Count
        LC2 = .Sheets(MySheet2).UsedRange.Rows.Count
        List1 = .Sheets(MySheet1).Range("A1:D" & LC1).Value
        List2 = .Sheets(MySheet2).Range("A1:D" & LC2).Value

For Loop2 = 2 To LC2

    If Len(List2(Loop2, 3)) > 0 Then
        List2(Loop2, 3) = Trim(List2(Loop2, 3))
    End If

Next Loop2

        With .Sheets(MySheet3)
            .Cells.ClearContents
            .Range("A1").Value = "Mismatched Records"
            .Range("A3").Value = "Unit Number"
            .Range("B2").Value = MySheet1
            .Range("E2").Value = MySheet2
            .Range("B3").Value = "Type"
            .Range("C3").Value = "Required Temperature"
            .Range("D3").Value = "Final Destination"
            .Range("E3").Value = "Type"
            .Range("F3").Value = "Required Temperature"
            .Range("G3").Value = "Final Destination"
        End With
        For Loop1 = 2 To LC1
            For Loop2 = 2 To LC2
                If Trim(List1(Loop1, 1)) = Trim(List2(Loop2, 1)) Then
                    For Loop3 = 2 To 4
                        If Trim(List1(Loop1, Loop3)) <> Trim(List2(Loop2, Loop3)) Then
                            With .Sheets(MySheet3)
                                .Range("A" & ORow).Value = List1(Loop1, 1)
                                .Range("B" & ORow).Value = List1(Loop1, 2)
                                .Range("C" & ORow).Value = List1(Loop1, 3)
                                .Range("D" & ORow).Value = List1(Loop1, 4)
                                .Range("E" & ORow).Value = List2(Loop2, 2)
                                .Range("F" & ORow).Value = List2(Loop2, 3)
                                .Range("G" & ORow).Value = List2(Loop2, 4)
                            End With
                            ORow = ORow + 1
                            Exit For
                        End If
                    Next Loop3
                    Exit For
                Else
                    DoEvents
                End If
            Next Loop2
        Next Loop1
    End With

    MsgBox "Finished", vbInformation, "Done!"

End Sub

但是代码不能正常工作——即它没有在输出表上列出现有的不匹配，也没有用红色突出显示不匹配的单元号。

Answer 1

我看到的问题是您的数据比较是基于键列匹配的。如果 Sheet1 的 A 列中的某个值在 Sheet2 的 A 列中不存在，则不会检查每个工作表的 B 到 D 列中的剩余值，并且不会报告任何内容。明智地使用 Exit For , For Each...Next Statement比较键列不应该达到它的终止。如果是这样，那么 Sheet1 的 A 列中有一些东西在 Sheet2 的 A 列中不存在，应该报告。

Option Explicit

Const MySheet1 As String = "Sheet1" 'list 1
Const MySheet2 As String = "Sheet2" 'list 2
Const MySheet3 As String = "Sheet3" 'output sheet

Sub CompareLists2()

    Dim List1 As Variant, List2 As Variant
    Dim LC1 As Long, LC2 As Long, ORow As Long
    Dim Loop1 As Long, Loop2 As Long, Loop3 As Long

    ORow = 4
    With ThisWorkbook
        LC1 = .Sheets(MySheet1).UsedRange.Rows.Count
        LC2 = .Sheets(MySheet2).UsedRange.Rows.Count
        List1 = .Sheets(MySheet1).Range("A1:D" & LC1).Value
        List2 = .Sheets(MySheet2).Range("A1:D" & LC2).Value

        For Loop2 = 2 To LC2
            List2(Loop2, 3) = Trim(List2(Loop2, 3))
        Next Loop2

        With .Sheets(MySheet3)
            .Cells.ClearContents
            .Range("A1").Value = "Mismatched Records"
            .Range("A3").Value = "Unit Number"
            .Range("B2").Value = MySheet1
            .Range("E2").Value = MySheet2
            .Range("B3").Value = "Type"
            .Range("C3").Value = "Required Temperature"
            .Range("D3").Value = "Final Destination"
            .Range("E3").Value = "Type"
            .Range("F3").Value = "Required Temperature"
            .Range("G3").Value = "Final Destination"
        End With

        For Loop1 = 2 To LC1
            For Loop2 = 2 To LC2
                If Trim(List1(Loop1, 1)) = Trim(List2(Loop2, 1)) Then
                    For Loop3 = 2 To 4
                        If Trim(List1(Loop1, Loop3)) <> Trim(List2(Loop2, Loop3)) Then
                            With .Sheets(MySheet3)
                                .Range("A" & ORow).Value = List1(Loop1, 1)
                                .Range("B" & ORow).Value = List1(Loop1, 2)
                                .Range("C" & ORow).Value = List1(Loop1, 3)
                                .Range("D" & ORow).Value = List1(Loop1, 4)
                                .Range("E" & ORow).Value = List2(Loop2, 2)
                                .Range("F" & ORow).Value = List2(Loop2, 3)
                                .Range("G" & ORow).Value = List2(Loop2, 4)
                            End With
                            ORow = ORow + 1
                            Exit For
                        End If
                    Next Loop3
                    Exit For
                ElseIf Loop2 = LC2 Then
                    'last loop and no match
                    'this reports sheet1 missing from sheet2
                    With .Sheets(MySheet3)
                        .Range("A" & ORow).Value = List1(Loop1, 1)
                        .Range("B" & ORow).Value = List1(Loop1, 2)
                        .Range("C" & ORow).Value = List1(Loop1, 3)
                        .Range("D" & ORow).Value = List1(Loop1, 4)
                    End With
                    ORow = ORow + 1
                End If
            Next Loop2
        Next Loop1

        'add a reverse loop for Sheet2 column A keys missing from Sheet1's column A
        For Loop2 = 2 To UBound(List2, 1)
            For Loop1 = 2 To UBound(List1, 1)
                If Trim(List1(Loop1, 1)) = Trim(List2(Loop2, 1)) Then
                    Exit For
                ElseIf Loop1 = UBound(List1, 1) Then
                    'last loop and no match
                    'this reports sheet2 missing from sheet1
                    With .Sheets(MySheet3)
                        .Range("A" & ORow).Value = List2(Loop2, 1)
                        .Range("E" & ORow).Value = List2(Loop2, 2)
                        .Range("F" & ORow).Value = List2(Loop2, 3)
                        .Range("G" & ORow).Value = List2(Loop2, 4)
                    End With
                    ORow = ORow + 1
                End If
            Next Loop1
        Next Loop2

    End With

    MsgBox "Finished", vbInformation, "Done!"

End Sub

我添加了一个半反向循环来捕获 Sheet2 的 A 列中未在 Sheet1 的 A 列中找到的键。