Excel VBA匹配两工作簿列值返回结果，如何优化代码缩短运行时长

原代码运行慢的核心原因 #

你当前代码的耗时主要来自三类高频开销：

• 循环内逐次调用Find方法，每次查询都要遍历整列，时间复杂度为O(n*m)，数据量越大耗时指数级上升
• 循环内逐次读取、写入单元格，频繁和工作表交互的IO开销极高
• 运行过程中Excel的屏幕刷新、自动重算等默认特性会带来不必要的性能消耗

优化实现方案 #

改用字典+数组批量读写的方案，可将运行时间压缩到秒级，代码如下：

Sub 匹配校验()
    Dim arrH, arrA, arrRes, i As Long, lastRow2 As Long, LastRow As Long
    Dim dict As Object
    ' 禁用耗时特性
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    
    Set dict = CreateObject("Scripting.Dictionary")
    ' 一次性读取工作簿2 BB表A列所有值存入字典
    With Workbooks("2.xlsx").Sheets("BB")
        lastRow2 = .Range("A" & .Rows.Count).End(xlUp).Row
        arrA = .Range("A1:A" & lastRow2).Value
    End With
    For i = 1 To UBound(arrA)
        If Not dict.exists(arrA(i, 1)) Then dict.Add arrA(i, 1), ""
    Next i
    
    ' 一次性读取工作簿1 AA表H列，同时初始化结果数组
    With Workbooks("1.xlsx").Sheets("AA")
        LastRow = .Range("H" & .Rows.Count).End(xlUp).Row
        arrH = .Range("H1:H" & LastRow).Value
        ReDim arrRes(1 To UBound(arrH), 1 To 1)
    End With
    
    ' 内存内完成匹配，全程无工作表交互
    For i = 1 To UBound(arrH)
        arrRes(i, 1) = IIf(dict.exists(arrH(i, 1)), "Y", "N")
    Next i
    
    ' 一次性写入S列所有结果
    Workbooks("1.xlsx").Sheets("AA").Range("S1:S" & LastRow).Value = arrRes
    
    ' 恢复Excel默认设置
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Set dict = Nothing
End Sub

注意事项 #

• 如果数据中存在大小写区分的匹配需求，可在字典创建后添加dict.CompareMode = vbBinaryCompare设置
• 如果遇到重复值的匹配需求，字典的存储逻辑也可根据需求调整，查询效率不会有明显变化

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