VBA如何将Sumifs计算结果存入数组后批量写入现有表格提效

问题场景 #

• 现有存储源数据的表格，样式如下：
  
• 需要将统计结果填充到跨工作表的目标表中，目标表样式如下：
  
• 原有实现痛点：逐列重复编写高度相似的SumIfs逻辑，仅修改最后一个条件参数取值，代码冗余度高，且逐单元格写入的方式运行效率低下。原有冗余代码片段如下：

'-------------
    '   RETAIL
    '-------------
    
    'assign the range of cells
    lr2 = WS5.Range("A" & Rows.Count).End(xlUp).row
    Set rngSum1 = WS5.Range("H2:H" & lr2)
    Set rngCriteria5 = WS5.Range("A2:A" & lr2)
    'Criteria5 = WS4.Cells(n, 10)
    Set rngCriteria6 = WS5.Range("D2:D" & lr2)
    'Criteria6 = WS4.Cells("T3")
    
    
    'use the ranges in the formula
    Dim m As Long
    Dim lr3 As Integer
    lr3 = WS4.Range("J" & Rows.Count).End(xlUp).row
    
    For m = 4 To lr3
        WS4.Cells(m, 20).Value = Application.WorksheetFunction.SumIfs(rngSum1, rngCriteria5, WS4.Cells(m, 10), rngCriteria6, WS4.Range("T3"))
    Next m
    
    'release the range object
    Set rngCriteria5 = Nothing
    Set rngCriteria6 = Nothing

    '-------------
    '   INDUSTRY
    '-------------
    
    'assign the range of cells
    lr2 = WS5.Range("A" & Rows.Count).End(xlUp).row
    Set rngSum1 = WS5.Range("H2:H" & lr2)
    Set rngCriteria5 = WS5.Range("A2:A" & lr2)
    'Criteria5 = WS4.Cells(n, 10)
    Set rngCriteria6 = WS5.Range("D2:D" & lr2)
    'Criteria6 = WS4.Cells("U3")
    
    
    'use the ranges in the formula
    Dim m As Long
    Dim lr3 As Integer
    lr3 = WS4.Range("J" & Rows.Count).End(xlUp).row
    
    For m = 4 To lr3
        WS4.Cells(m, 21).Value = Application.WorksheetFunction.SumIfs(rngSum1, rngCriteria5, WS4.Cells(m, 10), rngCriteria6, WS4.Range("U3"))
    Next m
    
    'release the range object
    Set rngCriteria5 = Nothing
    Set rngCriteria6 = Nothing

优化思路 #

完全可以通过数组批量计算+一次性写入的方式解决冗余和效率问题，核心优化点有三个：

• 把所有需要重复读取的源数据、目标匹配键一次性读入内存数组，避免反复和工作表交互，这是VBA提速最核心的手段
• 把不同统计列的差异化参数（目标列号、类型匹配值）做成配置数组，所有列复用同一套计算逻辑，新增统计列只需要加配置，不需要重复写代码
• 所有计算在内存中完成后，把结果数组一次性批量写入目标单元格区域，完全替代逐单元格赋值的操作

优化后代码 #

代码完全兼容你原有WS4（目标工作表）、WS5（源数据工作表）的对象定义，直接替换原有重复逻辑即可：

Sub BatchSumCalculate()
    ' 基础性能优化开关
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    
    Dim lr2 As Long, lr3 As Long, i As Long, j As Long, k As Long
    Dim sourceArr As Variant, matchKeyArr As Variant, resultArr As Variant
    
    ' 列配置：每一行对应一个统计列，依次填入【目标列号, 类型匹配值】
    ' 后续新增统计列只需要在此处追加配置即可，无需修改计算逻辑
    Dim colConfig As Variant
    colConfig = Array( _
        Array(20, WS4.Range("T3").Value), _ ' 对应原RETAIL列（T列，列号20）
        Array(21, WS4.Range("U3").Value) _  ' 对应原INDUSTRY列（U列，列号21）
        ' 示例：新增V列统计就追加下一行 Array(22, WS4.Range("V3").Value)
    )
    
    ' 一次性读取源数据需要的列（A列匹配键、D列类型、H列求和值）到内存
    lr2 = WS5.Range("A" & Rows.Count).End(xlUp).Row
    sourceArr = WS5.Range("A2:H" & lr2).Value
    
    ' 一次性读取目标表匹配键（J列从第4行开始）到内存，初始化结果数组
    lr3 = WS4.Range("J" & Rows.Count).End(xlUp).Row
    matchKeyArr = WS4.Range("J4:J" & lr3).Value
    ReDim resultArr(1 To UBound(matchKeyArr, 1), 1 To UBound(colConfig) + 1)
    
    ' 内存中完成所有匹配求和计算，全程不操作工作表
    For i = 1 To UBound(matchKeyArr, 1)
        For j = 0 To UBound(colConfig)
            Dim total As Double
            total = 0
            For k = 1 To UBound(sourceArr, 1)
                ' 双条件匹配：键相等 + 类型相等
                If sourceArr(k, 1) = matchKeyArr(i, 1) And sourceArr(k, 4) = colConfig(j)(1) Then
                    total = total + sourceArr(k, 8)
                End If
            Next k
            resultArr(i, j + 1) = total
        Next j
    Next i
    
    ' 结果一次性批量写入目标区域
    WS4.Cells(4, 20).Resize(UBound(resultArr, 1), UBound(resultArr, 2)).Value = resultArr
    
    ' 恢复Excel默认设置
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    
    ' 释放数组内存
    Erase sourceArr, matchKeyArr, resultArr, colConfig
End Sub

补充说明 #

• 如果源数据行数超过10万行，可以考虑用字典对象预聚合源数据，把遍历源数据的次数从「行数*列数」降到1次，速度还能进一步提升
• 如果你习惯用原有SumIfs工作表函数，也可以把计算结果先存入数组再批量写入，但是纯内存数组遍历的性能远高于反复调用工作表函数的方案
• 代码已经做了容错兼容，只要你原有工作表对象的引用正确，直接运行即可

内容的提问来源于stack exchange，提问作者Elisa R.