VBA中COUNTIF/SUMIF处理20万行数据过慢 寻求Dictionary优化方案

原代码性能极差的核心原因：

• 逐行循环执行FillDown、选中单元格操作，每一次操作都会触发Excel界面重绘、公式重算，20万行量级下重复触发十几万次，无意义开销占比超过95%
• 运行全程未关闭屏幕刷新、事件触发、自动计算，每一步单元格操作都会额外消耗资源
• 逐行填充公式的逻辑完全冗余，Excel支持对整段区域批量写入公式，不需要逐行操作

核心优化方向：

• 宏运行期间临时关闭屏幕更新、事件触发、自动计算，所有操作执行完成后统一恢复配置
• 完全移除Select选中单元格、逐行填充的低效逻辑，对目标区域直接批量操作
• 若不需要保留公式联动能力，可通过数组+字典在内存中完成全量统计，仅执行一次单元格写入操作，性能提升最明显

方案1：保留公式的兼容版本 #

和原代码统计逻辑完全一致，保留公式联动能力，源数据变动后统计值可自动更新，运行耗时从几十分钟压缩到数秒：

Sub Status_Optimized_WithFormula()
    Dim LR As Long
    ' 临时关闭非必要功能，核心提速配置
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    
    ' 错误捕获，保证代码报错时也能恢复Excel默认配置
    On Error GoTo RecoverConfig
    
    With Sheets("Amount")
        LR = .Cells(.Rows.Count, "B").End(xlUp).Row
        ' 一次性给整段目标区域批量写入公式，完全不需要循环
        .Range("C6:C" & LR).FormulaR1C1 = "=COUNTIF(Invoice!C2,Amount!RC[-1])"
        .Range("D6:D" & LR).FormulaR1C1 = "=SUMIF(Invoice!C2,Amount!RC2,Invoice!C6)"
        .Range("E6:E" & LR).FormulaR1C1 = "=SUMIF(Invoice!C2,Amount!RC2,Invoice!C7)"
        .Range("F6:F" & LR).FormulaR1C1 = "=SUMIF(Invoice!C2,Amount!RC2,Invoice!C8)"
    End With
    
RecoverConfig:
    ' 恢复Excel默认配置
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    If Err.Number <> 0 Then MsgBox "运行出错：" & Err.Description, vbExclamation
End Sub

方案2：极致性能的内存计算版本 #

不写入公式，直接在内存中完成全量聚合统计，输出静态结果，20万行数据1-2秒即可跑完，适合一次性出统计结果的场景：

Sub Status_Optimized_WithDictionary()
    Dim LR_Invoice As Long, LR_Amount As Long, i As Long
    Dim arrInvoice As Variant, arrAmount As Variant, arrRes As Variant
    Dim dictCount As Object, dictSumF As Object, dictSumG As Object, dictSumH As Object
    Dim matchKey As String
    
    ' 初始化字典用于聚合统计
    Set dictCount = CreateObject("Scripting.Dictionary")
    Set dictSumF = CreateObject("Scripting.Dictionary")
    Set dictSumG = CreateObject("Scripting.Dictionary")
    Set dictSumH = CreateObject("Scripting.Dictionary")
    
    ' 关闭非必要功能
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    On Error GoTo RecoverConfig
    
    ' 一次性把Invoice表所需数据全部读入内存数组
    With Sheets("Invoice")
        LR_Invoice = .Cells(.Rows.Count, "B").End(xlUp).Row
        arrInvoice = .Range("B2:H" & LR_Invoice).Value
    End With
    
    ' 内存中遍历完成计数、求和聚合，全程不操作单元格
    For i = 1 To UBound(arrInvoice)
        matchKey = Trim(CStr(arrInvoice(i, 1)))
        If matchKey <> "" Then
            dictCount(matchKey) = dictCount(matchKey) + 1
            If IsNumeric(arrInvoice(i, 5)) Then dictSumF(matchKey) = dictSumF(matchKey) + arrInvoice(i, 5)
            If IsNumeric(arrInvoice(i, 6)) Then dictSumG(matchKey) = dictSumG(matchKey) + arrInvoice(i, 6)
            If IsNumeric(arrInvoice(i, 7)) Then dictSumH(matchKey) = dictSumH(matchKey) + arrInvoice(i, 7)
        End If
    Next i
    
    ' 读取Amount表匹配键，批量匹配结果
    With Sheets("Amount")
        LR_Amount = .Cells(.Rows.Count, "B").End(xlUp).Row
        arrAmount = .Range("B6:B" & LR_Amount).Value
        ReDim arrRes(1 To UBound(arrAmount), 1 To 4)
        
        For i = 1 To UBound(arrAmount)
            matchKey = Trim(CStr(arrAmount(i, 1)))
            If dictCount.Exists(matchKey) Then
                arrRes(i, 1) = dictCount(matchKey)
                arrRes(i, 2) = dictSumF(matchKey)
                arrRes(i, 3) = dictSumG(matchKey)
                arrRes(i, 4) = dictSumH(matchKey)
            Else
                arrRes(i, 1) = 0
                arrRes(i, 2) = 0
                arrRes(i, 3) = 0
                arrRes(i, 4) = 0
            End If
        Next i
        
        ' 一次性把结果写入单元格，仅触发一次IO操作
        .Range("C6:F" & LR_Amount).Value = arrRes
    End With

RecoverConfig:
    ' 释放对象、恢复配置
    Set dictCount = Nothing
    Set dictSumF = Nothing
    Set dictSumG = Nothing
    Set dictSumH = Nothing
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    If Err.Number <> 0 Then MsgBox "运行出错：" & Err.Description, vbExclamation
End Sub

两个版本完全对齐原代码的统计规则，按需选择即可。

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