比较 2 组数据并将任何缺失值粘贴到另一张纸上

Question

所以我有一个包含 1000 多行的主工作表和另一个“应该”具有相同数据的工作表。但是，实际上有时主服务器中缺少一些，有时查询运行中缺少一些。
为简单起见，假设唯一 ID 在 B 列中。这是我的代码，但它非常慢，而且只进行单向比较。

我的理想代码应该是运行得更流畅一些，并为我提供主数据和查询中缺失的数据。

我提问的方式有问题吗，请告诉我。

Sub FindMissing()

    Dim lastRowE As Integer
    Dim lastRowF As Integer
    Dim lastRowM As Integer
    Dim foundTrue As Boolean


    lastRowE = Sheets("Master").Cells(Sheets("Master").Rows.Count, "B").End(xlUp).Row
    lastRowF = Sheets("Qry").Cells(Sheets("Qry").Rows.Count, "B").End(xlUp).Row
    lastRowM = Sheets("Mismatch").Cells(Sheets("Mismatch").Rows.Count, "B").End(xlUp).Row



    For i = 1 To lastRowE
        foundTrue = False
        For j = 1 To lastRowF
            If Sheets("Master").Cells(i, 2).Value = Sheets("Qry").Cells(j, 2).Value Then
                foundTrue = True
                Exit For
            End If
        Next j
        If Not foundTrue Then
            Sheets("Master").Rows(i).Copy Destination:= _
            Sheets("Mismatch").Rows(lastRowM + 1)
            lastRowM = lastRowM + 1
        End If
    Next i

End Sub

Answer 1

不要遍历工作表上的单元格。将所有值收集到变量数组中并在内存中处理。

Option Explicit

Sub YouSuckAtVBA()

    Dim i As Long, mm As Long
    Dim valsM As Variant, valsQ As Variant, valsMM As Variant

    With Worksheets("Master")
        valsM = .Range(.Cells(1, "B"), .Cells(.Rows.Count, "B").End(xlUp)).Value2
    End With

    With Worksheets("Qry")
        valsQ = .Range(.Cells(1, "B"), .Cells(.Rows.Count, "B").End(xlUp)).Value2
    End With

    ReDim valsMM(1 To (UBound(valsM, 1) + UBound(valsQ, 1)), 1 To 2)
    mm = 1
    valsMM(mm, 1) = "value"
    valsMM(mm, 2) = "missing from"

    For i = LBound(valsM, 1) To UBound(valsM, 1)
        If IsError(Application.Match(valsM(i, 1), valsQ, 0)) Then
            mm = mm + 1
            valsMM(mm, 1) = valsM(i, 1)
            valsMM(mm, 2) = "qry"
        End If
    Next i

    For i = LBound(valsQ, 1) To UBound(valsQ, 1)
        If IsError(Application.Match(valsQ(i, 1), valsM, 0)) Then
            mm = mm + 1
            valsMM(mm, 1) = valsQ(i, 1)
            valsMM(mm, 2) = "master"
        End If
    Next i

    valsMM = helperResizeArray(valsMM, mm)

    With Worksheets("Mismatch")
        With .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0)
            .Resize(UBound(valsMM, 1), UBound(valsMM, 2)) = valsMM
        End With
    End With

End Sub

Function helperResizeArray(vals As Variant, x As Long)
    Dim arr As Variant, i As Long

    ReDim arr(1 To x, 1 To 2)

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

    helperResizeArray = arr
End Function

您无法调整二维数组的第一个等级，因此我添加了一个辅助函数，该函数将在将结果放回不匹配工作表之前调整其大小。