使用VBA数组与Scripting.Dictionary优化十万条数据的SUMIFS计算问题

问题背景 #

手里有十万条数据，想用VBA数组结合Scripting.Dictionary实现高效SUMIFS计算，需求如下：

• 源数据存于DBALL工作表
• 计算结果输出到RECON工作表
• RECON表的计算逻辑：
  • B列（In）：按RECON!A2匹配DBALL!C列、RECON!B$1匹配DBALL!B列，求和DBALL!A列
  • C列（Out）：按RECON!A2匹配DBALL!C列、RECON!C$1匹配DBALL!B列，求和DBALL!A列
  • D列：B列与C列的差值

但找到的VBA代码运行结果和预期不符，原代码如下：

Sub SUMIFSFASTER()
    
    Dim arr, ws, rng As Range, keyCols, valueCol As Long, destCol As Long, i As Long, frm As String, sep As String
    Dim t, dict, arrOut(), arrValues(), v, tmp, n As Long
    
    keyCols = Array(2, 3)  'these columns form the composite key
    valueCol = 1             'column with values (for sum)
    destCol = 4               'destination for calculated values
    
    t = Timer
    
    Set ws = Sheets("DBALL")
    Set rng = ws.Range("A1").CurrentRegion
    n = rng.Rows.Count - 1
    Set rng = rng.Offset(1, 0).Resize(n) 'exclude headers
    
    'build the formula to create the row "key"
    For i = 0 To UBound(keyCols)
        frm = frm & sep & rng.Columns(keyCols(i)).Address
        sep = "&""|""&"
    Next i
    arr = ws.Evaluate(frm)  'get an array of composite keys by evaluating the formula
    arrValues = rng.Columns(valueCol).Value  'values to be summed
    ReDim arrOut(1 To n, 1 To 1)             'this is for the results
    
    Set dict = CreateObject("scripting.dictionary")
    'first loop over the array counts the keys
    For i = 1 To n
        v = arr(i, 1)
        If Not dict.exists(v) Then dict(v) = Array(0, 0) 'count, sum
        tmp = dict(v) 'can't modify an array stored in a dictionary - pull it out first
        tmp(0) = tmp(0) + 1                 'increment count
        tmp(1) = tmp(1) + arrValues(i, 1)   'increment sum
        dict(v) = tmp                       'return the modified array
    Next i
    
    'second loop populates the output array from the dictionary
    For i = 1 To n
        arrOut(i, 1) = dict(arr(i, 1))(1)                       'sumifs
        'arrOut(i, 1) = dict(arr(i, 1))(0)                      'countifs
        'arrOut(i, 1) = dict(arr(i, 1))(1) / dict(arr(i, 1))(0) 'averageifs
    Next i
    'populate the results
    rng.Columns(destCol).Value = arrOut
    
    Debug.Print "Checked " & n & " rows in " & Timer - t & " secs"

End Sub

原代码的问题 #

1. 复合键顺序错误：原代码用Array(2,3)对应DBALL的B、C列，但实际需求是先匹配DBALL的C列（对应RECON的A2）、再匹配DBALL的B列（对应RECON的表头），键顺序完全搞反，导致分组逻辑错误。
2. 输出目标错误：原代码把结果写回DBALL的第4列，完全没处理RECON工作表的输出需求。
3. 未适配RECON的二维结构：原代码只是给DBALL每行计算对应分组和，没有针对RECON的行-列交叉匹配逻辑进行计算。

修正后的VBA代码 #

Sub EfficientSUMIFSToRECON()
    Dim wsDB As Worksheet, wsRECON As Worksheet
    Dim arrDB As Variant, arrRECON As Variant
    Dim dict As Object
    Dim i As Long, j As Long
    Dim compositeKey As String
    Dim lastRowDB As Long, lastRowRECON As Long, lastColRECON As Long
    
    '初始化工作表对象
    Set wsDB = ThisWorkbook.Sheets("DBALL")
    Set wsRECON = ThisWorkbook.Sheets("RECON")
    Set dict = CreateObject("Scripting.Dictionary")
    
    '读取DBALL的源数据（含表头）
    lastRowDB = wsDB.Cells(wsDB.Rows.Count, "A").End(xlUp).Row
    arrDB = wsDB.Range("A1:C" & lastRowDB).Value
    
    '构建字典：复合键为【DBALL的C列值|DBALL的B列值】，存储对应A列的和
    For i = 2 To lastRowDB '跳过表头
        compositeKey = arrDB(i, 3) & "|" & arrDB(i, 2)
        If dict.Exists(compositeKey) Then
            dict(compositeKey) = dict(compositeKey) + arrDB(i, 1)
        Else
            dict(compositeKey) = arrDB(i, 1)
        End If
    Next i
    
    '读取RECON的结构（含表头）
    lastRowRECON = wsRECON.Cells(wsRECON.Rows.Count, "A").End(xlUp).Row
    lastColRECON = wsRECON.Cells(1, wsRECON.Columns.Count).End(xlToLeft).Column
    arrRECON = wsRECON.Range("A1:D" & lastRowRECON).Value
    
    '填充RECON的In、Out列
    For i = 2 To lastRowRECON '跳过表头行
        For j = 2 To 3 'B列(In)、C列(Out)
            compositeKey = arrRECON(i, 1) & "|" & arrRECON(1, j)
            arrRECON(i, j) = IIf(dict.Exists(compositeKey), dict(compositeKey), 0)
        Next j
        '计算D列差值
        arrRECON(i, 4) = arrRECON(i, 2) - arrRECON(i, 3)
    Next i
    
    '将结果写回RECON工作表
    wsRECON.Range("A1:D" & lastRowRECON).Value = arrRECON
    
    '释放对象
    Set dict = Nothing
    Set wsDB = Nothing
    Set wsRECON = Nothing
    
    MsgBox "计算完成！", vbInformation
End Sub

代码说明 #

• 复合键修正：严格按照需求构建键DBALL的C列值|DBALL的B列值，和RECON的SUMIFS匹配逻辑完全一致。
• 高效批量处理：把DBALL和RECON的数据都读入数组，所有计算在内存中完成，最后一次性写回工作表，十万条数据也能快速处理。
• 空值容错：如果没有匹配到对应键，返回0，避免出现错误值。
• 差值计算：直接在数组中完成B-C的差值计算，无需额外公式。

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