VBA遍历比对大型交易列表的代码性能优化方案

实现目标 #

开发VBA宏程序比对随交易过账持续增长的新旧两份交易列表（TL）差异，实现旧交易列表 + 变更内容 = 新交易列表的比对逻辑。

现有匹配规则 #

新旧TL存储在两个独立工作表，列布局完全一致，按以下规则标记匹配状态：

• 精确匹配（Exact match）：两表对应行的拼接字符串完全一致
• 部分匹配（Partial match）：拼接字符串不完全相同，但两表存在相同凭证号（document number）的记录
• 无匹配（No match）：既无完全一致的拼接字符串，也找不到对应相同凭证号的记录

现存问题 #

现有代码可正常运行，但处理合计5万条记录的两个工作表时耗时约15分钟，运行效率极低。代码中仅nrws、cls为Double类型变量，其余变量均为Range类型，需要优化运行速度。
现有待优化代码片段：

For l = 2 To nrws
    Set nkey = nTL.Cells(l, cls + 1)
    Set ndoc = nTL.Cells(l, 5)
    nTL.Cells(l, cls + 2) = Application.WorksheetFunction.CountIf(nkeyList, nkey)
    nTL.Cells(l, cls + 3) = Application.WorksheetFunction.CountIf(okeyList, nkey)
    nTL.Cells(l, cls + 4) = Application.WorksheetFunction.CountIf(ndocList, ndoc)
    nTL.Cells(l, cls + 5) = Application.WorksheetFunction.CountIf(odocList, ndoc)
    If nTL.Cells(l, cls + 3) = 0 Then
        If nTL.Cells(l, cls + 5) = 0 Then
            nTL.Cells(l, cls + 6) = "No Match"
        Else: nTL.Cells(l, cls + 6) = "Partial Match"
        End If
    ElseIf nTL.Cells(l, cls + 2) = nTL.Cells(l, cls + 3) And nTL.Cells(l, cls + 4) = nTL.Cells(l, cls + 5) Then
        nTL.Cells(l, cls + 6) = "Exact Match"
    ElseIf nTL.Cells(l, cls + 2) = nTL.Cells(l, cls + 3) Then
        nTL.Cells(l, cls + 6) = "Partial Match"
    Else
        nTL.Cells(l, cls + 6) = "Check"
    End If
Next l

核心优化思路是减少VBA与工作表的交互次数、用字典哈希查找替代逐行CountIf遍历、关闭不必要的Excel后台功能，优化后5万行数据处理耗时可降到秒级：

1. 前置基础环境优化 #

在代码执行前关闭Excel的非必要功能，执行完成后恢复，避免每次单元格操作触发界面刷新、公式重算：

' 代码执行前开启优化
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
' 原有业务逻辑写在这里
' 代码执行完成后恢复配置
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True

2. 用内存数组替代逐单元格读写 #

逐行读取/写入单元格是VBA常见性能瓶颈，一次性将所有需要处理的范围读入内存数组，所有计算在内存中完成，最后一次性将结果写回工作表，可减少99%以上的工作表交互开销。

3. 用Dictionary字典替代CountIf做计数 #

CountIf每次调用都会遍历整个目标范围，5万行循环下时间复杂度为O(n²)；改用Scripting.Dictionary的哈希查找，统计key、凭证号的出现次数仅需数次线性遍历，时间复杂度降到O(n)，查找效率提升几个数量级。

优化后完整参考代码 #

Sub OptimizeTLMatch()
    Dim oTL As Worksheet, nTL As Worksheet
    Dim nrws As Long, cls As Long, oNrws As Long
    Dim nkeyList, okeyList, ndocList, odocList
    Dim arrRes
    Dim dictNKey As Object, dictOKey As Object, dictNDoc As Object, dictODoc As Object
    Dim i As Long, lRow As Long
    Dim cntNKey As Long, cntOKey As Long, cntNDoc As Long, cntODoc As Long
    
    ' 初始化工作表，根据实际修改表名
    Set oTL = ThisWorkbook.Worksheets("旧TL")
    Set nTL = ThisWorkbook.Worksheets("新TL")
    nrws = nTL.Cells(nTL.Rows.Count, 1).End(xlUp).Row
    oNrws = oTL.Cells(oTL.Rows.Count, 1).End(xlUp).Row
    cls = nTL.UsedRange.Columns.Count
    
    ' 开启环境优化
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    
    ' 初始化字典
    Set dictNKey = CreateObject("Scripting.Dictionary")
    Set dictOKey = CreateObject("Scripting.Dictionary")
    Set dictNDoc = CreateObject("Scripting.Dictionary")
    Set dictODoc = CreateObject("Scripting.Dictionary")
    
    ' 一次性将所有列表范围读入数组，替代逐单元格读取
    nkeyList = nTL.Range(nTL.Cells(2, cls + 1), nTL.Cells(nrws, cls + 1)).Value
    okeyList = oTL.Range(oTL.Cells(2, cls + 1), oTL.Cells(oNrws, cls + 1)).Value
    ndocList = nTL.Range(nTL.Cells(2, 5), nTL.Cells(nrws, 5)).Value
    odocList = oTL.Range(oTL.Cells(2, 5), oTL.Cells(oNrws, 5)).Value
    
    ' 统计新表key出现次数
    For i = 1 To UBound(nkeyList, 1)
        If Not dictNKey.Exists(nkeyList(i, 1)) Then
            dictNKey(nkeyList(i, 1)) = 1
        Else
            dictNKey(nkeyList(i, 1)) = dictNKey(nkeyList(i, 1)) + 1
        End If
    Next i
    
    ' 统计旧表key出现次数
    For i = 1 To UBound(okeyList, 1)
        If Not dictOKey.Exists(okeyList(i, 1)) Then
            dictOKey(okeyList(i, 1)) = 1
        Else
            dictOKey(okeyList(i, 1)) = dictOKey(okeyList(i, 1)) + 1
        End If
    Next i
    
    ' 统计新表凭证号出现次数
    For i = 1 To UBound(ndocList, 1)
        If Not dictNDoc.Exists(ndocList(i, 1)) Then
            dictNDoc(ndocList(i, 1)) = 1
        Else
            dictNDoc(ndocList(i, 1)) = dictNDoc(ndocList(i, 1)) + 1
        End If
    Next i
    
    ' 统计旧表凭证号出现次数
    For i = 1 To UBound(odocList, 1)
        If Not dictODoc.Exists(odocList(i, 1)) Then
            dictODoc(odocList(i, 1)) = 1
        Else
            dictODoc(odocList(i, 1)) = dictODoc(odocList(i, 1)) + 1
        End If
    Next i
    
    ' 初始化结果数组，存储所有计算结果
    ReDim arrRes(1 To nrws - 1, 1 To 5)
    ' 逐行在内存中计算匹配状态，无工作表交互
    For lRow = 2 To nrws
        i = lRow - 1
        ' 从字典取计数，不存在则为0
        cntNKey = dictNKey(nkeyList(i, 1))
        cntOKey = IIf(dictOKey.Exists(nkeyList(i, 1)), dictOKey(nkeyList(i, 1)), 0)
        cntNDoc = dictNDoc(ndocList(i, 1))
        cntODoc = IIf(dictODoc.Exists(ndocList(i, 1)), dictODoc(ndocList(i, 1)), 0)
        
        ' 沿用原有判断逻辑
        If cntOKey = 0 Then
            If cntODoc = 0 Then
                arrRes(i, 5) = "No Match"
            Else
                arrRes(i, 5) = "Partial Match"
            End If
        ElseIf cntNKey = cntOKey And cntNDoc = cntODoc Then
            arrRes(i, 5) = "Exact Match"
        ElseIf cntNKey = cntOKey Then
            arrRes(i, 5) = "Partial Match"
        Else
            arrRes(i, 5) = "Check"
        End If
        ' 写入四个计数值
        arrRes(i, 1) = cntNKey
        arrRes(i, 2) = cntOKey
        arrRes(i, 3) = cntNDoc
        arrRes(i, 4) = cntODoc
    Next lRow
    
    ' 一次性把所有结果写回工作表
    nTL.Cells(2, cls + 2).Resize(UBound(arrRes, 1), UBound(arrRes, 2)).Value = arrRes
    
    ' 恢复Excel配置
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    
    ' 释放对象
    Set dictNKey = Nothing
    Set dictOKey = Nothing
    Set dictNDoc = Nothing
    Set dictODoc = Nothing
End Sub

额外注意点 #

• 行号、列号变量不要用Double类型，统一用Long类型，避免隐式类型转换开销，也防止数据量超过范围溢出。
• 如果不需要统计key、凭证号的出现次数，仅判断是否存在，直接用字典的Exists方法返回布尔值即可，不需要计数，速度会更快。
• 范围变量不要在循环内反复Set，所有范围引用一次性确定后读入内存即可。

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