优化匹配Dictionary条目计数的VBA代码性能

现有VBA代码可准确统计数千条Dictionary中符合条件的条目，按ANG、ARB、ANGAus、ARBAus分类，匹配Output工作表的Locations并累加计数，但求和过程耗时超出预期。由于需通过Process工作表的进度条向用户反馈执行状态（避免用户误以为程序卡顿），无法禁用屏幕更新。当前代码重复遍历4个Dictionary，通过WorksheetFunction.Match定位对应行并累加计数，现寻求更高效的优化方案。

原代码 #

Dim row as Integer

' 包含按钮和进度条的工作表
Dim pSheet As Object
Set pSheet = Excel.ThisWorkbook.Worksheets("Process") 

' 包含地点列表及各类统计结果的工作表（约800个地点）
Dim oSheet As Object
Set oSheet = Excel.ThisWorkbook.Worksheets("Output") 

' 存储各类去重后的条目
Dim dictAng As New Scripting.Dictionary 
Dim dictArb As New Scripting.Dictionary
Dim dictAusAng As New Scripting.Dictionary
Dim dictAusArb As New Scripting.Dictionary

row = 0
For Each key In dictAng.Keys
    pSheet.Range("N12") = pSheet.Range("N12") + 1 ' 通过条件格式更新进度条
    row = WorksheetFunction.Match(dictAng.Item(key), oSheet.Range("E:E"), 0) ' 匹配对应地点行
    oSheet.Cells(row, 7).Value = oSheet.Cells(row, 7).Value + 1 ' 累加计数
Next

row = 0
For Each key In dictArb.Keys
    pSheet.Range("N12") = pSheet.Range("N12") + 1 ' 通过条件格式更新进度条
    row = WorksheetFunction.Match(dictArb.Item(key), oSheet.Range("E:E"), 0)
    oSheet.Cells(row, 8).Value = oSheet.Cells(row, 8).Value + 1
Next

row = 0
For Each key In dictAusAng.Keys
    pSheet.Range("N12") = pSheet.Range("N12") + 1 ' 通过条件格式更新进度条
    row = WorksheetFunction.Match(dictAusAng.Item(key), oSheet.Range("E:E"), 0) 
    oSheet.Cells(row, 9).Value = oSheet.Cells(row, 9).Value + 1 
Next

row = 0
For Each key In dictAusArb.Keys
    pSheet.Range("N12") = pSheet.Range("N12") + 1
    row = WorksheetFunction.Match(dictAusArb.Item(key), oSheet.Range("E:E"), 0)
    oSheet.Cells(row, 10).Value = oSheet.Cells(row, 10).Value + 1
Next

输出示例 #

优化方案 #

核心优化思路 #

• 预构建地点-行号映射字典：把Output表的地点和对应行号提前存入字典，避免每次循环都调用WorksheetFunction.Match（这是最大性能瓶颈，每次Match都会遍历整列）。
• 内存数组批量操作：先将统计结果存入内存数组，最后一次性写入工作表，大幅减少VBA与Excel界面的交互次数。
• 降低进度条更新频率：按批次更新进度条（比如每100条更新一次），用DoEvents确保屏幕刷新，平衡进度反馈与性能损耗。

优化后的代码 #

Dim row As Integer
Dim locRowMap As New Scripting.Dictionary ' 存储地点到行号的映射
Dim outputArr() As Variant ' 存储统计结果的内存数组
Dim lastRow As Long
Dim totalItems As Long
Dim currentCount As Long

' 初始化工作表对象
Dim pSheet As Worksheet
Set pSheet = ThisWorkbook.Worksheets("Process")
Dim oSheet As Worksheet
Set oSheet = ThisWorkbook.Worksheets("Output")

' 1. 预构建地点-行号映射字典（仅执行一次）
lastRow = oSheet.Cells(oSheet.Rows.Count, "E").End(xlUp).Row
For row = 2 To lastRow ' 假设第1行是表头
    Dim locKey As String
    locKey = Trim(oSheet.Cells(row, "E").Value)
    If Not locRowMap.Exists(locKey) Then
        locRowMap.Add locKey, row
    End If
Next row

' 2. 初始化统计数组，读取现有值到内存
ReDim outputArr(2 To lastRow, 7 To 10) As Variant
For row = 2 To lastRow
    outputArr(row, 7) = oSheet.Cells(row, 7).Value
    outputArr(row, 8) = oSheet.Cells(row, 8).Value
    outputArr(row, 9) = oSheet.Cells(row, 9).Value
    outputArr(row, 10) = oSheet.Cells(row, 10).Value
Next row

' 3. 计算总条目数，用于进度条计算
totalItems = dictAng.Count + dictArb.Count + dictAusAng.Count + dictAusArb.Count
currentCount = 0

' 处理ANG字典
For Each key In dictAng.Keys
    currentCount = currentCount + 1
    ' 每100条更新一次进度条
    If currentCount Mod 100 = 0 Then
        pSheet.Range("N12").Value = currentCount
        DoEvents ' 确保屏幕刷新
    End If
    Dim locVal As String
    locVal = Trim(dictAng.Item(key))
    If locRowMap.Exists(locVal) Then
        row = locRowMap(locVal)
        outputArr(row, 7) = outputArr(row, 7) + 1
    End If
Next

' 处理ARB字典
For Each key In dictArb.Keys
    currentCount = currentCount + 1
    If currentCount Mod 100 = 0 Then
        pSheet.Range("N12").Value = currentCount
        DoEvents
    End If
    locVal = Trim(dictArb.Item(key))
    If locRowMap.Exists(locVal) Then
        row = locRowMap(locVal)
        outputArr(row, 8) = outputArr(row, 8) + 1
    End If
Next

' 处理ANGAus字典
For Each key In dictAusAng.Keys
    currentCount = currentCount + 1
    If currentCount Mod 100 = 0 Then
        pSheet.Range("N12").Value = currentCount
        DoEvents
    End If
    locVal = Trim(dictAusAng.Item(key))
    If locRowMap.Exists(locVal) Then
        row = locRowMap(locVal)
        outputArr(row, 9) = outputArr(row, 9) + 1
    End If
Next

' 处理ARBAus字典
For Each key In dictAusArb.Keys
    currentCount = currentCount + 1
    If currentCount Mod 100 = 0 Then
        pSheet.Range("N12").Value = currentCount
        DoEvents
    End If
    locVal = Trim(dictAusArb.Item(key))
    If locRowMap.Exists(locVal) Then
        row = locRowMap(locVal)
        outputArr(row, 10) = outputArr(row, 10) + 1
    End If
Next

' 4. 一次性将统计结果写入工作表
oSheet.Cells(2, 7).Resize(lastRow - 1, 4).Value = outputArr(2 To lastRow, 7 To 10)
' 更新最终进度条
pSheet.Range("N12").Value = totalItems
DoEvents

优化效果说明 #

• 映射字典替代Match：将原本O(n*m)的时间复杂度降到O(n+m)，彻底消除重复遍历整列的开销。
• 内存数组操作：所有计数累加在内存中完成，仅一次写入操作，避免频繁读写工作表的性能损耗。
• 进度条批量更新：减少屏幕刷新次数，既保证用户能看到执行进度，又不会因频繁刷新拖慢程序。

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