Question

所以我有一张1000+行的主表和另一张表＆＃34;应该＆＃34;拥有相同的数据。但是，实际上有时候主人会遗漏一些，有时候查询运行中会遗漏一些为简单起见，我们假设唯一的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

您无法调整2D数组的第一个等级，因此我添加了一个辅助函数，可以在将结果重新放入Mismatch工作表之前调整结果大小。

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

1 个答案: