如何提升实现类VLOOKUP功能的VBA代码在大数据量下的运行速度

核心问题说明 #

你原代码的性能瓶颈主要来自两个方面：

• 嵌套循环实现匹配，时间复杂度为O(n*m)，数据量越大耗时指数级上升
• 循环内频繁读写工作表单元格，读写单元格的操作远慢于内存操作

优化后代码 #

Sub Rectangle1_Click()
    ' 声明所有变量类型，避免默认Variant损耗
    Dim i As Long, j As Long, lastG As Long, lastD As Long
    Dim lookupDict As Object
    Dim arrSheet1 As Variant, arrSheet2 As Variant
    Dim key As String
    
    ' 关闭不必要的系统属性，提升运行速度
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .CutCopyMode = False
        .Calculation = xlCalculationManual ' 新增关闭自动计算
    End With
    
    ' 初始化字典，用于存储Sheet1的A列值到行号的映射
    Set lookupDict = CreateObject("Scripting.Dictionary")
    
    ' 获取两个工作表的最后行
    lastG = Sheets("sheet2").Cells(Rows.Count, "A").End(xlUp).Row
    lastD = Sheets("sheet1").Cells(Rows.Count, "A").End(xlUp).Row
    
    ' 将Sheet1需要用到的所有列一次性读入数组，减少单元格读写次数
    arrSheet1 = Sheets("sheet1").Range("A1:AP" & lastD).Value
    
    ' 遍历Sheet1数组，将A列值作为键，行号作为值存入字典，仅需遍历1次
    For j = 2 To lastD
        key = CStr(arrSheet1(j, 1)) ' A列是第1列
        If Not lookupDict.exists(key) Then
            lookupDict.Add key, j
        End If
    Next j
    
    ' 将Sheet2需要匹配和写入的区域一次性读入数组
    arrSheet2 = Sheets("sheet2").Range("A1:L" & lastG).Value
    
    ' 遍历Sheet2数组，直接用字典匹配，无需嵌套循环
    For i = 2 To lastG
        key = CStr(arrSheet2(i, 1))
        If lookupDict.exists(key) Then
            j = lookupDict(key)
            ' 直接在数组内赋值，速度远快于单元格写入
            arrSheet2(i, 2) = arrSheet1(j, 20) ' T列→Sheet2 B列
            arrSheet2(i, 3) = arrSheet1(j, 21) ' U列→Sheet2 C列
            arrSheet2(i, 4) = arrSheet1(j, 22) ' V列→Sheet2 D列
            arrSheet2(i, 5) = arrSheet1(j, 2)  ' B列→Sheet2 E列
            arrSheet2(i, 6) = arrSheet1(j, 3)  ' C列→Sheet2 F列
            arrSheet2(i, 7) = arrSheet1(j, 42) ' AP列→Sheet2 G列
            arrSheet2(i, 8) = arrSheet1(j, 7)  ' G列→Sheet2 H列
            arrSheet2(i, 9) = arrSheet1(j, 10) ' J列→Sheet2 I列
            arrSheet2(i, 10) = arrSheet1(j, 12) ' L列→Sheet2 J列
            arrSheet2(i, 11) = arrSheet1(j, 13) ' M列→Sheet2 K列
            arrSheet2(i, 12) = arrSheet1(j, 14) ' N列→Sheet2 L列
        End If
    Next i
    
    ' 将处理完的数组一次性写回Sheet2，仅需1次写单元格操作
    Sheets("sheet2").Range("A1:L" & lastG).Value = arrSheet2
    
    ' 恢复系统属性
    With Application
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
        .CutCopyMode = True
        .ScreenUpdating = True
    End With
    
    ' 释放对象内存
    Set lookupDict = Nothing
End Sub

优化点说明 #

• 用字典存储Sheet1的匹配键映射，将匹配逻辑的时间复杂度从O(n*m)降至O(n+m)，是性能提升的核心
• 所有数据操作先在内存数组中完成，避免了循环内成千上万次的单元格读写操作，整体速度可提升几十到上百倍
• 新增关闭自动计算，避免匹配过程中公式反复重算带来的额外损耗
• 修正了原代码变量声明不规范的问题，避免Variant类型带来的额外性能开销

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