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

所以我有一个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 

您无法调整二维数组的第一个排名，所以我添加了一个帮助函数，在将结果放回到“不匹配”工作表之前将调整结果的大小。