Question

我正在尝试匹配大型数据集，并使用VBA将值从一个工作表复制到另一个工作表。我目前正在使用Vlookup，但是对于我正在测试的单列而言，这个过程非常缓慢，因为它不可行。有没有更有效的方法来匹配基于密钥的数据？基本上我的数据看起来像这样，我试图使用'密钥'将数据集A中的'数据'复制到B

数据集A：

Key  Data
123  yes
231  yes
435  no

数据集B：

Key  Data
453  
231

我的代码目前如下：

    Sub copyData()

Dim myLastRow As Long
Dim backlogSheet As Worksheet
Dim combinedSheet As Worksheet

Set backlogSheet = Sheets("All SAMs Backlog")
Set combinedSheet = Sheets("COMBINED")
myLastRow = backlogSheet.Cells(Rows.Count, "B").End(xlUp).Row

Application.ScreenUpdating = False

For myRow = 3 To myLastRow

    curLoc = backlogSheet.Cells(myRow, "C")

    searchVal = Range("D" & myRow).Value

    statusVal = Application.VLookup(curLoc, combinedSheet.Range("A:B"), 2, False)

    'Range("D" & myRow).Cells.Value = testVal
Next myRow

MsgBox ("done")
End Sub

感谢任何帮助。

Answer 1

从源填充字典，获取目标数组并使用源字典填充它，最后将结果数组放回目标工作表。

Sub copyData()
    Dim i As Long, arr As Variant, dict As Object

    Set dict = CreateObject("scripting.dictionary")
    dict.comparemode = vbTextCompare

    With Worksheets("COMBINED")
        'put combined!a:b into a variant array
        arr = .Range(.Cells(2, "A"), .Cells(.Rows.Count, "B").End(xlUp)).Value2
        'loop through array and build dictionary keys from combined!a:a, dictionary item from combined!b:b
        For i = LBound(arr, 1) To UBound(arr, 1)
            dict.Item(arr(i, 1)) = arr(i, 2)
        Next i
    End With

    With Worksheets("All SAMs Backlog")
        'put 'all sams backlog'!c:d into a variant array
        arr = .Range(.Cells(3, "C"), .Cells(.Rows.Count, "C").End(xlUp).Offset(0, 1)).Value2
        'loop through array and if c:c matches combined!a:a then put combined!b:b into d:d
        For i = LBound(arr, 1) To UBound(arr, 1)
            If dict.exists(arr(i, 1)) Then
                arr(i, 2) = dict.Item(arr(i, 1))
            Else
                arr(i, 2) = vbNullString
            End If
        Next i
        'put populated array back into c3 (resized by rows and columns)
        .Cells(3, "C").Resize(UBound(arr, 1), UBound(arr, 2)) = arr
    End With

    MsgBox ("done")

End Sub

更快的VBA VLookup替代基于密钥检索数据

1 个答案: