基于列A与列H多条件的Excel多工作簿汇总VBA代码优化

核心解决思路 #

• 先遍历所有目标工作簿，收集**列A（业务代码）与列H（Uplift Code）**的所有唯一值组合，空值场景统一标记为"无Uplift码"，避免匹配异常
• 基于唯一组合，跨所有工作簿执行双条件求和：匹配列A代码+列H标识，累加对应行的列F数值
• 最后将汇总结果输出到新建工作表，清晰展示每个组合的求和结果

完整优化代码 #

Sub 按双条件汇总多工作簿数据()
    Dim wb As Workbook, ws As Worksheet
    Dim sourcePath As Variant, resultWs As Worksheet
    Dim uniqueDict As Object, keyStr As String
    Dim lastRow As Long, i As Long, sumVal As Double
    Dim upliftCode As String
    
    ' 创建字典存储唯一的A+H组合
    Set uniqueDict = CreateObject("Scripting.Dictionary")
    uniqueDict.CompareMode = vbTextCompare ' 不区分大小写，按需调整
    
    ' 选择目标工作簿
    sourcePath = Application.GetOpenFilename("Excel文件 (*.xlsx;*.xls), *.xlsx;*.xls", _
        Title:="选择需要汇总的46个工作簿", MultiSelect:=True)
    If IsEmpty(sourcePath) Then Exit Sub
    
    ' 第一步：收集所有唯一的A+H组合
    For Each path In sourcePath
        Set wb = Workbooks.Open(path, ReadOnly:=True)
        Set ws = wb.Sheets(1) ' 假设数据在第一个工作表，按需修改
        lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
        
        For i = 2 To lastRow ' 跳过表头，从第2行开始
            ' 处理H列空值，统一标记为"无Uplift码"
            upliftCode = IIf(Trim(ws.Cells(i, "H").Value) = "", "无Uplift码", ws.Cells(i, "H").Value)
            ' 生成组合键：A列代码 + 分隔符 + Uplift码
            keyStr = ws.Cells(i, "A").Value & "|" & upliftCode
            If Not uniqueDict.Exists(keyStr) Then
                uniqueDict.Add keyStr, 0 ' 初始值设为0，后续累加
            End If
        Next i
        
        wb.Close SaveChanges:=False
    Next path
    
    ' 第二步：基于唯一组合，跨工作簿求和
    For Each path In sourcePath
        Set wb = Workbooks.Open(path, ReadOnly:=True)
        Set ws = wb.Sheets(1)
        lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
        
        For i = 2 To lastRow
            upliftCode = IIf(Trim(ws.Cells(i, "H").Value) = "", "无Uplift码", ws.Cells(i, "H").Value)
            keyStr = ws.Cells(i, "A").Value & "|" & upliftCode
            ' 累加F列数值
            uniqueDict(keyStr) = uniqueDict(keyStr) + ws.Cells(i, "F").Value
        Next i
        
        wb.Close SaveChanges:=False
    Next path
    
    ' 第三步：输出汇总结果到新工作表
    Set resultWs = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
    resultWs.Name = "双条件汇总结果"
    
    ' 写入表头
    resultWs.Cells(1, "A").Value = "业务代码"
    resultWs.Cells(1, "B").Value = "Uplift Code"
    resultWs.Cells(1, "C").Value = "汇总F列数值"
    resultWs.Rows(1).Font.Bold = True
    
    ' 写入数据
    i = 2
    For Each keyStr In uniqueDict.Keys
        resultWs.Cells(i, "A").Value = Split(keyStr, "|")(0)
        resultWs.Cells(i, "B").Value = Split(keyStr, "|")(1)
        resultWs.Cells(i, "C").Value = uniqueDict(keyStr)
        i = i + 1
    Next keyStr
    
    ' 自动调整列宽
    resultWs.Columns("A:C").AutoFit
    MsgBox "汇总完成！结果已保存到工作表：" & resultWs.Name, vbInformation
End Sub

关键代码说明 #

• 字典处理唯一组合：用Scripting.Dictionary存储列A与列H的组合键，自动去重，避免重复计算
• 空值兼容：通过IIf函数将H列空值转换为固定标识"无Uplift码"，确保空值场景能被精准匹配
• 只读打开工作簿：打开源文件时使用ReadOnly:=True，避免锁定文件或意外修改
• 分阶段执行：先收集所有唯一组合再求和，减少重复遍历次数，提升效率

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