数千行数据对账时VBA宏运行过慢，如何优化现有代码？

原代码运行极慢的核心原因有两点：一是采用了双层嵌套循环遍历行，时间复杂度为O(n*m)，几千行数据就会产生数百万次运算；二是全程直接读写单元格，VBA中每次单元格交互的开销极高，同时原代码还存在逻辑bug（内部表拼接匹配键的循环错误引用了外部表的行数据，会导致匹配结果出错）。

优化后代码数千行数据运行耗时可压缩至10秒以内，代码如下：

Sub 对账优化()
    Dim ws_rexternal As Worksheet, ws_rinternal As Worksheet
    Dim ws_unmatched As Worksheet, ws_matched As Worksheet
    Dim ex_arr, in_arr, key, k, r
    Dim ex_LR As Long, in_LR As Long, i As Long, m_idx As Long
    Dim match_dict As Object, matched_ex As Collection, matched_in As Collection
    Dim unmatched_ex As Collection, unmatched_in As Collection
    
    ' 关闭屏幕更新、自动计算降低性能开销
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    ' 初始化工作表，清空原有结果
    Set ws_rexternal = ThisWorkbook.Worksheets("Reformat External")
    Set ws_rinternal = ThisWorkbook.Worksheets("Reformat Internal")
    Set ws_unmatched = ThisWorkbook.Worksheets("Unmatched")
    Set ws_matched = ThisWorkbook.Worksheets("Matched")
    ws_matched.Cells.Clear
    ws_unmatched.Cells.Clear
    
    ' 一次性读取所有数据到内存数组，避免反复读写单元格
    ex_LR = ws_rexternal.Cells(Rows.Count, 2).End(xlUp).Row
    in_LR = ws_rinternal.Cells(Rows.Count, 2).End(xlUp).Row
    ex_arr = ws_rexternal.Range("A1:M" & ex_LR).Value
    in_arr = ws_rinternal.Range("A1:M" & in_LR).Value
    
    ' 用字典存储内部表的匹配键和对应行号，支持重复值匹配
    Set match_dict = CreateObject("Scripting.Dictionary")
    Set matched_in = New Collection
    For i = 2 To in_LR
        key = Join(Application.Index(in_arr, i, 0), ",")
        If Not match_dict.exists(key) Then
            Set match_dict(key) = New Collection
        End If
        match_dict(key).Add i
    Next i
    
    ' 遍历外部表做匹配，时间复杂度O(n)
    Set matched_ex = New Collection
    Set unmatched_ex = New Collection
    ' 先存入表头
    matched_ex.Add Application.Index(ex_arr, 1, 0)
    unmatched_ex.Add Application.Index(ex_arr, 1, 0)
    For i = 2 To ex_LR
        key = Join(Application.Index(ex_arr, i, 0), ",")
        If match_dict.exists(key) And match_dict(key).Count > 0 Then
            ' 匹配成功存入匹配集合，移除已匹配的内部表行避免重复匹配
            matched_ex.Add Application.Index(ex_arr, i, 0)
            matched_in.Add Application.Index(in_arr, match_dict(key)(1), 0)
            match_dict(key).Remove 1
        Else
            ' 未匹配存入未匹配集合
            unmatched_ex.Add Application.Index(ex_arr, i, 0)
        End If
    Next i
    
    ' 收集内部表剩余未匹配的行
    unmatched_in.Add Application.Index(in_arr, 1, 0)
    For Each k In match_dict.keys
        For Each r In match_dict(k)
            unmatched_in.Add Application.Index(in_arr, r, 0)
        Next
    Next
    
    ' 批量写入匹配表
    m_idx = 1
    For i = 1 To matched_ex.Count
        ws_matched.Range("A" & m_idx).Resize(1, 13).Value = matched_ex(i)
        ws_matched.Cells(m_idx, 14).Value = "Matched"
        ws_matched.Cells(m_idx, 14).Interior.Color = RGB(0, 255, 0)
        If i <= matched_in.Count Then
            ws_matched.Range("O" & m_idx).Resize(1, 13).Value = matched_in(i)
        End If
        m_idx = m_idx + 1
    Next
    
    ' 批量写入未匹配表
    m_idx = 1
    For i = 1 To unmatched_ex.Count
        ws_unmatched.Range("A" & m_idx).Resize(1, 13).Value = unmatched_ex(i)
        m_idx = m_idx + 1
    Next
    m_idx = m_idx + 5 ' 空5行分隔外部/内部未匹配数据
    For i = 1 To unmatched_in.Count
        ws_unmatched.Range("A" & m_idx).Resize(1, 13).Value = unmatched_in(i)
        m_idx = m_idx + 1
    Next
    
    ' 恢复Excel默认设置
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub

核心优化说明 #

• 用数组代替单元格读写：所有数据一次性读入内存运算，避免每次循环和单元格交互，速度提升数十倍
• 用字典替换双层嵌套循环：将其中一张表的匹配键提前存入字典，遍历另一张表时用O(1)复杂度查询是否匹配，时间复杂度从O(n*m)降低到O(n+m)
• 关闭不必要的Excel功能：运行时暂停屏幕刷新和自动公式计算，减少无效性能开销
• 修复原代码逻辑bug：原代码拼接内部表匹配键时错误引用了外部表的行数据，会导致匹配结果完全错误
• 批量写入结果：所有匹配/未匹配数据先在内存中整理完成，最后一次性写入工作表，大幅减少写入次数

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