优化VBA双数组模拟VLOOKUP并填充输出数组的运行速度

问题背景 #

本人是VBA初学者，现有一段实现跨工作表ID匹配、按行内条件填充目标列的VBA代码，运行耗时过长（一段约2分50秒，另一段约1分25秒）。已尝试添加Erase语句清理数组，且启用了指定的OptimizedMode优化模块，但仍需更高效的实现方案。

原代码 #

Pref子程序 #

Sub Pref()
'insert account pref data into dataset

Dim wsP As Worksheet
Dim wIP As Worksheet
Dim lrow As Long
Dim lRow2 As Long
Dim b As Long
Dim bizArr As Variant
Dim outArr As Variant
Dim Searchfor As Variant
Dim p As Variant
Dim pArr As Variant

Set wsP = Sheets("Preferences")
    With wsP
    lrow = .Cells(Rows.Count, "A").End(xlUp).Row
    pArr = Range(.Cells(1, 1), .Cells(lrow, 6))
    End With
    
Set wIP = Sheets("Working Issue Pay Data")
    With wIP
    lRow2 = .Cells(Rows.Count, "A").End(xlUp).Row
    bizArr = Range(.Cells(1, 1), .Cells(lRow2, 1))
    outArr = Range(Cells(1, 17), Cells(lRow2, 27))
    End With

        On Error Resume Next
           For b = 2 To lRow2
           For p = 2 To lrow
           Searchfor = bizArr(b, 1)
           If pArr(p, 1) = Searchfor Then
               If pArr(p, 3) = "ACH" And pArr(p, 5) = "Yes" Then
                   outArr(b, 1) = pArr(p, 5)
               ElseIf pArr(p, 3) = "Payment" Then
                   outArr(b, 2) = pArr(p, 5)
                   outArr(b, 3) = pArr(p, 6)
               ElseIf pArr(p, 3) = "Lien" Then
                   outArr(b, 4) = pArr(p, 4)
                   outArr(b, 5) = pArr(p, 6)
               ElseIf pArr(p, 3) = "Defer Pay" And pArr(p, 5) = "Yes" Then
                   outArr(b, 7) = pArr(p, 5)
                   outArr(b, 8) = pArr(p, 6)
            Exit For
           End If
           End If
        Next p
        Next b
 
wIP.Range(Cells(1, 17), Cells(lRow2, 27)) = outArr

End Sub

已启用的OptimizedMode优化模块 #

Public Sub OptimizedMode(ByVal enable As Boolean)
' attempt to speed up Build macro

     Application.EnableEvents = Not enable
     Application.Calculation = IIf(enable, xlCalculationManual, xlCalculationAutomatic)
     Application.ScreenUpdating = Not enable
     Application.EnableAnimations = Not enable
     Application.DisplayStatusBar = Not enable
     Application.PrintCommunication = Not enable
     
End Sub

优化后的代码 #

Sub Optimized_Pref()
    ' 开启优化模式
    OptimizedMode True
    
    Dim wsP As Worksheet, wIP As Worksheet
    Dim lrow As Long, lRow2 As Long
    Dim pArr As Variant, outArr As Variant
    Dim prefDict As Object
    Dim b As Long, p As Long
    Dim key As Variant, prefItem As Variant
    
    ' 初始化字典
    Set prefDict = CreateObject("Scripting.Dictionary")
    
    ' 读取Preferences表数据到数组，并构建字典
    Set wsP = Sheets("Preferences")
    With wsP
        lrow = .Cells(.Rows.Count, "A").End(xlUp).Row
        pArr = .Range(.Cells(1, 1), .Cells(lrow, 6)).Value ' 加.确保引用当前工作表
    End With
    
    ' 遍历Preferences数据，按ID分组存储所有匹配项
    For p = 2 To lrow
        key = pArr(p, 1)
        If Not prefDict.Exists(key) Then
            prefDict(key) = New Collection
        End If
        ' 将当前行的关键数据存入集合：类型、列4值、列5值、列6值
        prefDict(key).Add Array(pArr(p, 3), pArr(p, 4), pArr(p, 5), pArr(p, 6))
    Next p
    
    ' 读取目标表数据和输出数组
    Set wIP = Sheets("Working Issue Pay Data")
    With wIP
        lRow2 = .Cells(.Rows.Count, "A").End(xlUp).Row
        outArr = .Range(.Cells(1, 17), .Cells(lRow2, 27)).Value ' 修正引用问题
    End With
    
    ' 遍历目标表，通过字典快速匹配ID并填充数据
    For b = 2 To lRow2
        key = wIP.Cells(b, 1).Value ' 直接读取ID，无需单独bizArr
        If prefDict.Exists(key) Then
            ' 遍历当前ID的所有偏好项
            For Each prefItem In prefDict(key)
                Select Case prefItem(0)
                    Case "ACH"
                        If prefItem(2) = "Yes" Then
                            outArr(b, 1) = prefItem(2)
                        End If
                    Case "Payment"
                        outArr(b, 2) = prefItem(2)
                        outArr(b, 3) = prefItem(3)
                    Case "Lien"
                        outArr(b, 4) = prefItem(1)
                        outArr(b, 5) = prefItem(3)
                    Case "Defer Pay"
                        If prefItem(2) = "Yes" Then
                            outArr(b, 7) = prefItem(2)
                            outArr(b, 8) = prefItem(3)
                        End If
                End Select
            Next prefItem
        End If
    Next b
    
    ' 将数组写回工作表
    wIP.Range(wIP.Cells(1, 17), wIP.Cells(lRow2, 27)).Value = outArr
    
    ' 清理对象
    Set prefDict = Nothing
    Set wsP = Nothing
    Set wIP = Nothing
    
    ' 关闭优化模式
    OptimizedMode False
End Sub

核心优化点 #

1. 替换嵌套循环为字典查找：原代码使用两层嵌套循环（O(n*m)复杂度），优化后用字典存储ID对应的所有偏好项，查找复杂度降为O(n+m)，大幅减少运算次数。
2. 修正工作表引用错误：原代码中Range(.Cells(1,1),...)缺少前缀.，会错误引用活动工作表，优化后统一使用.Range确保引用当前With块的工作表。
3. 移除不必要的错误处理：原代码的On Error Resume Next会隐藏潜在错误，优化后去掉该语句，便于排查问题。
4. 减少数组冗余：原代码单独声明bizArr存储ID，优化后直接从目标表读取ID，减少内存占用。
5. 统一资源清理：手动释放字典和工作表对象，避免内存泄漏。

内容的提问来源于stack exchange，提问作者user24198610