VBA代码：一键汇总求和N个工作簿N个工作表

你是不是也这样？

每个月都要收齐**A部门、B部门、C部门……**十几个Excel文件（1个工作簿里有N个工作表），然后打开每个文件、复制每个工作表里的数据，再粘贴到总表里，还要按机构号一个个对号入座……搞到天黑眼都花，一不小心还粘错行！

今天分享的这段VBA代码，就是帮你一键搞定多工作簿、多工作表的数据汇总求和！犀利吧？

它能解决什么问题？

• • 场景：你有1个总表（里面列好了所有机构号），还有N个部门发来的Excel文件，每个文件里又有好几个工作表，每个表里散落着各种“指标1”“指标2”……
• • 需求：要把所有部门文件里出现的指标，按机构号汇总到总表里，而且只汇总“求和顺序”表里指定的那些指标。
• • 手工做：打开一个文件→找指标→复制→切回总表→定位→粘贴→累加……重复几十次，想死的心都有。
• • 用代码：一键运行，不到1分钟搞定！
• 

代码逻辑（用学习场景比喻）

把总表里的机构号当成班级花名册，每个部门文件就是各科的作业本，作业本里有很多页（工作表），每页可能有不同科目的成绩（指标）。代码就像一个超认真的课代表：

1. 1. 先记下总表里有哪些同学（机构号）。
2. 2. 再翻开“求和顺序”这张纸条，看看要收哪几科的成绩（指标1、指标2……）。
3. 3. 然后抱着一叠作业本，一页一页翻，找到每个同学的名字，把他这一页的成绩抄下来，加到总表的格子里面。
4. 4. 所有作业本翻完，总表里的成绩就自动算好了，不用你动手抄一个数字！

上代码！复制就能用

（记得把总表放在一个文件夹里，其他部门文件也放同一个文件夹）

Sub 多工作簿汇总_根据汇总条件()    Dim wbSummary As Workbook    Dim wsCondition As Worksheet, wsOrder As Worksheet    Dim dictRow As Object              ' 条件组合 → 行号    Dim fieldToCol As Object            ' 求和字段名 → 列号    Dim orderFields As Variant          ' 求和字段顺序数组    Dim lastRowCond As Long, lastColOrder As Long    Dim i As Long, j As Long    Dim key As String    Dim filePath As String, fileName As String    Dim wbData As Workbook    Dim wsData As Worksheet    Dim dataArr As Variant    Dim cond1 As String, cond2 As String    Dim rowIdx As Long    Dim colIdx As Long    Dim fieldName As String    Dim resultArr() As Variant          ' 存储累加结果    Dim totalRows As Long, totalCols As Long    Dim headerDict As Object    Set wbSummary = ThisWorkbook    Set wsCondition = wbSummary.Worksheets("汇总")    Set wsOrder = wbSummary.Worksheets("求和顺序")    ' -------------------- 1. 读取“汇总”表中的条件组合 --------------------    lastRowCond = wsCondition.Cells(wsCondition.Rows.Count, 1).End(xlUp).Row    If lastRowCond < 2 Then        MsgBox "“汇总”工作表没有条件数据（至少需要一行条件）！", vbExclamation        Exit Sub    End If    Set dictRow = CreateObject("Scripting.Dictionary")    For i = 2 To lastRowCond        key = Trim(wsCondition.Cells(i, 1).Value) & Trim(wsCondition.Cells(i, 2).Value)        dictRow(key) = i    Next i    ' -------------------- 2. 读取“求和顺序”工作表中的字段标题 --------------------    lastColOrder = wsOrder.Cells(1, wsOrder.Columns.Count).End(xlToLeft).Column    If lastColOrder < 1 Then        MsgBox "“求和顺序”工作表没有字段标题！", vbExclamation        Exit Sub    End If    ReDim orderFields(1 To lastColOrder)    For j = 1 To lastColOrder        orderFields(j) = Trim(wsOrder.Cells(1, j).Value)    Next j    ' -------------------- 3. 在“汇总”表中设置求和列标题，并清空旧数据 --------------------    If lastRowCond > 1 Then        wsCondition.Range(wsCondition.Cells(2, 3), wsCondition.Cells(lastRowCond, wsCondition.Columns.Count)).ClearContents    End If    Set fieldToCol = CreateObject("Scripting.Dictionary")    For j = 1 To UBound(orderFields)        wsCondition.Cells(1, 2 + j).Value = orderFields(j)        fieldToCol(orderFields(j)) = 2 + j    Next j    ' -------------------- 4. 准备结果数组（初始化为0） --------------------    totalRows = lastRowCond - 1    totalCols = UBound(orderFields)    ReDim resultArr(1 To totalRows, 1 To totalCols)    For i = 1 To totalRows        For j = 1 To totalCols            resultArr(i, j) = 0        Next j    Next i    ' -------------------- 5. 遍历当前目录下的所有Excel文件 --------------------    filePath = ThisWorkbook.Path & "\"    fileName = Dir(filePath & "*.xlsx")    Application.ScreenUpdating = False    Application.DisplayAlerts = False    Do While fileName <> ""        If fileName <> ThisWorkbook.Name Then            On Error Resume Next            Set wbData = Workbooks.Open(filePath & fileName)            On Error GoTo 0            If Not wbData Is Nothing Then                For Each wsData In wbData.Worksheets                    dataArr = wsData.UsedRange.Value                    If IsArray(dataArr) Then                        If UBound(dataArr, 1) >= 2 Then                            Set headerDict = CreateObject("Scripting.Dictionary")                            For j = 1 To UBound(dataArr, 2)                                If Trim(dataArr(1, j)) <> "" Then                                    headerDict(Trim(dataArr(1, j))) = j                                End If                            Next j                            For i = 2 To UBound(dataArr, 1)                                cond1 = Trim(dataArr(i, 1))                                cond2 = Trim(dataArr(i, 2))                                key = cond1 & cond2                                If dictRow.exists(key) Then                                    rowIdx = dictRow(key) - 1                                    For j = 1 To totalCols                                        fieldName = orderFields(j)                                        If headerDict.exists(fieldName) Then                                            colIdx = headerDict(fieldName)                                            If IsNumeric(dataArr(i, colIdx)) Then                                                resultArr(rowIdx, j) = resultArr(rowIdx, j) + dataArr(i, colIdx)                                            End If                                        End If                                    Next j                                End If                            Next i                        End If                    End If                Next wsData                wbData.Close False            End If        End If        fileName = Dir    Loop    ' -------------------- 6. 将累加结果写回“汇总”工作表 --------------------    For i = 1 To totalRows        For j = 1 To totalCols            wsCondition.Cells(i + 1, 2 + j).Value = resultArr(i, j)        Next j    Next i    Application.ScreenUpdating = True    Application.DisplayAlerts = True    MsgBox "汇总完成！共处理 " & totalRows & " 行条件，求和字段数：" & totalCols, vbInformationEnd Sub

怎么用？

1. 1. 把总表（就是有这个VBA代码的文件）和所有部门文件放到同一个文件夹里。
2. 2. 在总表的“汇总”工作表里填好所有机构号（A列）和机构名称（B列）。
3. 3. 在“求和顺序”工作表第一行填好你要汇总的指标名称（比如指标1、指标2……顺序随便你）。
4. 4. 按下 Alt+F8，选中这个宏，点击“运行”。
5. 5. 等几秒钟（文件多的话喝口水），搞定！

温馨提示

• • 第一次用记得备份原文件，免得数据搞乱了。
• • 代码只会累加数字，不是数字的单元格会自动跳过，放心。
• • 如果某个指标没在任何文件里出现，那它在总表里就是0。

这么牛的代码，赶紧收藏起来啦！

#VBA #EXCEL技巧 #自动化办公#多工作簿多工作表合并

　　由于公众号推送规则调整，“设为星标” 是确保您能准时收到我们原创内容的最佳方式。

✨ 请您花2秒完成：

1. 点击顶部公众号名称，进入主页。

2. 点击右上角 【…】，选择 【设为星标】。

您的👍 点赞 +转发 + 在看，是对我们持续分享的最大支持！

感谢您阅读至此。

　　为保障账号持续运营与内容创作，文中或文末可能会穿插由平台智能推荐的内容，仅供参考，您可根据自身需求自由选择。我们的核心始终不变：与您一起，每天进步一点！💪

对微信公众号设置星标及后台发送消息