嘿，针对你的VBA求和需求，我有两个非常实用的方案，既能避免冗余又方便后续扩展逻辑，比用两个Dictionary靠谱多了！

方案一：自定义类模块 + Dictionary（推荐，扩展性强） #

这个方法把每个唯一键对应的求和值封装成一个对象，逻辑清晰，后续加新的求和项（比如数值3）也超级方便。

步骤1：创建自定义类 #

1. 打开VBA编辑器，右键点击项目 → 插入 → 类模块
2. 把类模块的名称改成PersonSum（在属性窗口里修改）
3. 类模块里写入以下代码：

Public Name As String       ' 唯一键（比如姓名）
Public SumVal1 As Double    ' 数值1的求和结果
Public SumVal2 As Double    ' 数值2的求和结果

步骤2：主程序实现遍历与求和 #

Sub SumByUniqueKey()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim dict As Object
    Dim personSum As PersonSum
    Dim outputWs As Worksheet
    Dim outputRow As Long
    
    ' 创建Dictionary对象（后期绑定，无需手动添加引用）
    Set dict = CreateObject("Scripting.Dictionary")
    
    ' 新建输出工作表
    Set outputWs = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
    outputWs.Name = "求和结果"
    ' 写入表头
    outputWs.Range("A1:C1") = Array("姓名", "数值1求和", "数值2求和")
    outputRow = 2
    
    ' 遍历所有工作表（跳过输出表避免重复处理）
    For Each ws In ThisWorkbook.Sheets
        If ws.Name <> "求和结果" Then
            lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
            ' 从第2行开始遍历（假设第1行是表头，无表头则改从1开始）
            For i = 2 To lastRow
                ' 检查布尔值列（这里假设是D列，根据你的实际情况修改）
                If ws.Cells(i, "D").Value = True Then
                    Dim currentName As String
                    currentName = ws.Cells(i, "A").Value
                    Dim val1 As Double, val2 As Double
                    val1 = ws.Cells(i, "B").Value
                    val2 = ws.Cells(i, "C").Value
                    
                    ' 处理字典中的唯一键
                    If dict.Exists(currentName) Then
                        ' 取出已有的对象，累加数值
                        Set personSum = dict(currentName)
                        personSum.SumVal1 = personSum.SumVal1 + val1
                        personSum.SumVal2 = personSum.SumVal2 + val2
                    Else
                        ' 新建对象并初始化
                        Set personSum = New PersonSum
                        personSum.Name = currentName
                        personSum.SumVal1 = val1
                        personSum.SumVal2 = val2
                        dict.Add currentName, personSum
                    End If
                End If
            Next i
        End If
    Next ws
    
    ' 将结果写入输出工作表
    For Each personSum In dict.Items
        outputWs.Cells(outputRow, "A").Value = personSum.Name
        outputWs.Cells(outputRow, "B").Value = personSum.SumVal1
        outputWs.Cells(outputRow, "C").Value = personSum.SumVal2
        outputRow = outputRow + 1
    Next personSum
    
    ' 释放对象，避免内存泄漏
    Set dict = Nothing
    Set personSum = Nothing
    Set outputWs = Nothing
    
    MsgBox "求和完成！结果已写入新工作表。"
End Sub

这个方案的优势在于：所有和唯一键相关的求和值都绑定在一个对象里，后续要加新的求和项，只需要在类模块里加一个属性（比如SumVal3），然后在代码里对应累加即可，完全不用改动字典的核心逻辑。

方案二：Dictionary存储数组（无需类模块，快速实现） #

如果不想创建类模块，用数组存储多个求和值也是个不错的选择，代码更简洁。

主程序代码 #

Sub SumByUniqueKeyWithArray()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim dict As Object
    Dim outputWs As Worksheet
    Dim outputRow As Long
    Dim sumArray As Variant
    
    Set dict = CreateObject("Scripting.Dictionary")
    
    ' 新建输出表
    Set outputWs = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
    outputWs.Name = "求和结果"
    outputWs.Range("A1:C1") = Array("姓名", "数值1求和", "数值2求和")
    outputRow = 2
    
    ' 遍历工作表
    For Each ws In ThisWorkbook.Sheets
        If ws.Name <> "求和结果" Then
            lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
            For i = 2 To lastRow
                If ws.Cells(i, "D").Value = True Then
                    Dim currentName As String
                    currentName = ws.Cells(i, "A").Value
                    Dim val1 As Double, val2 As Double
                    val1 = ws.Cells(i, "B").Value
                    val2 = ws.Cells(i, "C").Value
                    
                    ' 处理数组求和
                    If dict.Exists(currentName) Then
                        sumArray = dict(currentName)
                        sumArray(0) = sumArray(0) + val1
                        sumArray(1) = sumArray(1) + val2
                        dict(currentName) = sumArray
                    Else
                        ' 初始化数组并存入字典
                        dict.Add currentName, Array(val1, val2)
                    End If
                End If
            Next i
        End If
    Next ws
    
    ' 写入结果
    Dim key As Variant
    For Each key In dict.Keys
        outputWs.Cells(outputRow, "A").Value = key
        outputWs.Cells(outputRow, "B").Value = dict(key)(0)
        outputWs.Cells(outputRow, "C").Value = dict(key)(1)
        outputRow = outputRow + 1
    Next key
    
    Set dict = Nothing
    Set outputWs = Nothing
    MsgBox "求和完成！"
End Sub

这个方案适合快速实现，不用额外创建类模块。如果后续要加新的求和项，只需要把数组长度增加（比如Array(val1, val2, val3)），然后对应修改写入代码的列数即可。

一些注意事项 #

• 代码中布尔值列（D列）、数值列（B/C列）、唯一键列（A列）的位置，要根据你的实际表格结构调整；
• 如果你的表格没有表头，记得把循环起始行从2改成1；
• 两种方案都用了后期绑定的Dictionary，不用手动添加Microsoft Scripting Runtime引用，兼容性更好。

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