优化VBA数组求和循环：解决多数组累加效率低下问题

原代码的核心问题是频繁读写单个单元格，这是VBA操作Excel时的性能瓶颈。优化思路是一次性将每个工作表的目标区域读入内存数组，在内存中完成累加计算，最后一次性输出结果，彻底减少和Excel界面的交互次数。

具体实现代码 #

Sub SumMultipleSheets()
    ' 关闭后台操作提升速度
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    
    Dim wsList As Variant
    Dim targetRange As String
    Dim resultArr As Variant
    Dim tempArr As Variant
    Dim i As Long, j As Long, wsIdx As Long
    
    ' 定义需要累加的工作表名称列表（可按需扩展）
    wsList = Array("AAAA", "BBBB", "CCCC", "DDDD")
    ' 目标区域与原代码一致：U3到BN4421
    targetRange = "U3:BN4421"
    
    ' 初始化结果数组：读取第一个工作表的区域作为初始值
    resultArr = Worksheets(wsList(0)).Range(targetRange).Value
    ' 将空单元格转为0，避免累加错误
    For i = LBound(resultArr, 1) To UBound(resultArr, 1)
        For j = LBound(resultArr, 2) To UBound(resultArr, 2)
            resultArr(i, j) = IIf(IsEmpty(resultArr(i, j)), 0, resultArr(i, j))
        Next j
    Next i
    
    ' 遍历剩余工作表，批量读取并累加
    For wsIdx = 1 To UBound(wsList)
        ' 一次性读取当前工作表的目标区域到临时数组
        tempArr = Worksheets(wsList(wsIdx)).Range(targetRange).Value
        
        ' 内存中完成数组累加
        For i = LBound(resultArr, 1) To UBound(resultArr, 1)
            For j = LBound(resultArr, 2) To UBound(resultArr, 2)
                resultArr(i, j) = resultArr(i, j) + IIf(IsEmpty(tempArr(i, j)), 0, tempArr(i, j))
            Next j
        Next i
    Next wsIdx
    
    ' 一次性将结果写入目标工作表
    Worksheets("Sheet1").Range(targetRange).Value = resultArr
    
    ' 恢复Excel默认设置
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
End Sub

关键优化点说明 #

• 批量读写数组：每个工作表仅做一次区域读取和一次结果写入，避免了原代码中数万次的单个单元格读写操作，这是性能提升的核心。
• 内存内计算：所有累加操作在内存数组中完成，速度远快于直接操作单元格。
• 空单元格处理：用IIf(IsEmpty(...), 0, ...)将空单元格转为0，解决了MMULT方案无法处理空值的问题。
• 关闭后台开销：临时关闭屏幕刷新、事件触发和自动计算，进一步减少额外性能损耗。

扩展建议 #

如果需要累加的工作表数量极多，可以自动遍历筛选目标工作表，比如：

' 示例：累加所有名称以"DATA_"开头的工作表
Dim ws As Worksheet
wsList = Array()
For Each ws In ThisWorkbook.Worksheets
    If Left(ws.Name, 5) = "DATA_" Then
        ReDim Preserve wsList(UBound(wsList) + 1)
        wsList(UBound(wsList)) = ws.Name
    End If
Next ws

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