咨询：如何用Excel VBA高效实现多组日期范围/数组的匹配合并

你遇到的问题非常典型——数组公式在大数据量下的重复计算会导致性能爆炸，尤其是当你每行都执行一次跨整个表的数组求和时，时间复杂度直接从线性变成了平方级。下面给你一套基于字典（Dictionary）预处理+数组批量操作的高效方案，能把你的执行时间从分钟级压缩到秒级。

原方案慢的核心原因 #

你的原步骤中，每行的数组公式=SUM(IF((DAY(T_1[Date])=DAY([@Date]))*(MONTH(T_1[Date])=MONTH([@Date]))*(YEAR(T_1[Date])=YEAR([@Date])),T_1[Result1]))本质上是对T_1表做了一次全表遍历。假设T_1有5000行，结果表也有5000行，那就是5000×5000=2500万次运算，再加上20个Result列，运算量直接破亿，速度慢是必然的。

优化思路：提前分组求和，再批量写入 #

我们可以先遍历一次源数据，用字典把每个日期对应的所有Result列的总和都计算好，然后直接给结果表的日期匹配对应的值。整个过程只需要遍历源数据1次，结果表1次，时间复杂度是O(N+M)，性能提升非常明显。

完整VBA代码示例 #

Sub EfficientDateMatchSum()
    Dim ws As Worksheet
    Dim loSource As ListObject, loOutput As ListObject
    Dim arrSource As Variant, arrOutput As Variant
    Dim dict As Object
    Dim i As Long, j As Long
    Dim dateKey As String
    Dim minDate As Date, maxDate As Date
    Dim currentDate As Date
    Dim resultColsCount As Integer ' Result列的数量，比如20个
    
    ' --- 初始化设置（关键优化）---
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    
    ' 替换成你的工作表和表名
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    Set loSource = ws.ListObjects("T_1")
    Set loOutput = ws.ListObjects("Output")
    resultColsCount = 20 ' 根据你的实际Result列数量调整
    
    ' 1. 把源数据读入数组（比直接操作Range快N倍）
    arrSource = loSource.DataBodyRange.Value
    
    ' 2. 初始化字典，键为日期字符串"YYYY-MM-DD"，值为存储各Result列总和的数组
    Set dict = CreateObject("Scripting.Dictionary")
    For i = LBound(arrSource, 1) To UBound(arrSource, 1)
        ' 统一日期键格式，避免因日期存储格式导致不匹配
        dateKey = Format(arrSource(i, 1), "YYYY-MM-DD") ' 假设源表第1列是Date列
        If Not dict.Exists(dateKey) Then
            ' 初始化Result列总和数组，默认值0
            ReDim tempArr(1 To resultColsCount)
            For j = 1 To resultColsCount
                tempArr(j) = 0
            Next j
            dict(dateKey) = tempArr
        End If
        ' 累加各Result列的值（假设源表第2列开始是Result1、Result2...Result20）
        For j = 1 To resultColsCount
            dict(dateKey)(j) = dict(dateKey)(j) + arrSource(i, 1 + j)
        Next j
    Next i
    
    ' 3. 确定结果表的日期范围
    minDate = WorksheetFunction.Min(loSource.ListColumns("Date").DataBodyRange)
    maxDate = WorksheetFunction.Max(loSource.ListColumns("Date").DataBodyRange)
    
    ' 4. 清空结果表并调整行数
    If Not loOutput.DataBodyRange Is Nothing Then
        loOutput.DataBodyRange.Delete
    End If
    loOutput.ListRows.Add Count:=maxDate - minDate + 1
    
    ' 5. 准备结果数组
    arrOutput = loOutput.DataBodyRange.Value
    currentDate = minDate
    For i = LBound(arrOutput, 1) To UBound(arrOutput, 1)
        ' 写入日期列（假设结果表第1列是Date列）
        arrOutput(i, 1) = currentDate
        dateKey = Format(currentDate, "YYYY-MM-DD")
        ' 写入各Result列的总和（假设结果表第2列开始是Result1、Result2...Result20）
        If dict.Exists(dateKey) Then
            For j = 1 To resultColsCount
                arrOutput(i, 1 + j) = dict(dateKey)(j)
            Next j
        Else
            ' 如果该日期没有数据，填0或空
            For j = 1 To resultColsCount
                arrOutput(i, 1 + j) = 0
            Next j
        End If
        currentDate = currentDate + 1
    Next i
    
    ' 6. 把结果数组一次性写入结果表
    loOutput.DataBodyRange.Value = arrOutput
    
    ' --- 恢复设置 ---
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    
    MsgBox "计算完成！"
End Sub

额外优化建议 #

• 数组优先：所有单元格操作都尽量先读入数组，处理完再一次性写入，避免频繁读写单元格的开销。
• 关闭不必要的功能：代码开头的ScreenUpdating、EnableEvents、Calculation设置是VBA性能优化的标配，一定要加上。
• 日期键的稳定性：用Format(date, "YYYY-MM-DD")作为字典键，比直接用Date类型更稳妥，避免因Excel日期存储的浮点精度问题导致匹配失败。
• ListObject操作简化：清空结果表时直接删除DataBodyRange，比逐行删除快很多；调整行数时用ListRows.Add Count:=xxx批量添加，而不是循环添加。

用这个方案处理3161行×40列的测试数据，执行时间应该能控制在1秒以内，远快于原来的数组公式方案。

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