合并多个excel表中相同sheet的数据

合并多个excel表中相同sheet的数据

1.把要进行汇总的表（相同格式）放在同一个文件夹，如下图，然后把同样格式的空表也一同放在文件夹下，如下图（对文件夹的名字，路径没有要求）
2.点击打开 空表，同时保证此时电脑只打开空表这一个excel，不能打开多个excel。在打开的excel中按alt+F11，把下面代码复制粘贴（按需修改），按F5执行代码。

'统计多个excel表格的数据，每个行列值累加汇总到一个表格中
Sub 情况表汇总()
    '当前活动文件的目录
    dirPath = ActiveWorkbook.Path
     '当前活动文件的名字
    awbname = ActiveWorkbook.Name
    fname = Dir(dirPath & "\" & "*.xls")
    
    '要计算的数据起始到结束的位置，数组大小为4（表示有4个标签页）
    Dim dataSrcArray(4) As String
    dataSrcArray(0) = "C8:Z21"
    dataSrcArray(1) = "C8:W12"
    dataSrcArray(2) = "C8:H16"
    dataSrcArray(3) = "B2:G4"
    
    Dim g As Long
    'Dim fileNameArr(20) As String
    Dim f As String
    '获取文件列表
    '创建一个字典对象,将目录下文件放入字典的key中（除了当前活动的文件）
    Set DicList = CreateObject("Scripting.Dictionary")
    While fname <> ""
        'Debug.Print "fileName: "; fname
        '增加key,value
        If fname <> awbname Then
            DicList.Add fname, ""
        End If
        fname = Dir
    Wend
    
    fileNameList = DicList.Keys
    
    '循环计算标签页
    For g = 1 To Sheets.Count
         '声明一动态二维数组
         Dim totalRC() As Variant
         Dim rowSize
         Dim colSize
         
         flag = True
         
         '循环读取多个excel文件
         For Each fileNameKey In fileNameList
             f = dirPath & "\" & fileNameKey
          
             Set wb = Workbooks.Open(f)
             Set rg = wb.Sheets(g).Range(dataSrcArray(g - 1))
             
             '获取一个表格数据的行列数,设置明确最终数据的行列数，只赋值一次，用于初始化累计值的数组
             If (flag) Then
                 rowSize = rg.Rows.Count
                 colSize = rg.Columns.Count
                 '明确数组大小
                 ReDim totalRC(rowSize, colSize)
                 flag = False
             End If
                         
             
             For r = 1 To rowSize
                 For c = 1 To colSize
                    If VBA.IsNumeric(rg.Item(r, c)) Or Len(rg.Item(r, c)) <> 0 Then
                    '获取第r行第c列的数据值，累加到totalRC数组中
                       totalRC(r, c) = totalRC(r, c) + rg.Item(r, c)
                    End If
                 Next
             Next
             '关闭文件
             wb.Close False
         Next
         
        
         '先清空标签中的数据，再写入新数据
         'ThisWorkbook.Sheets(g).UsedRange.ClearContents
         For i = 1 To rowSize
             For j = 1 To colSize
             '分情况填写数据
                If g <> 4 Then
                 'Debug.Print i; j; totalRC(i, j)
                    ThisWorkbook.Sheets(g).Cells(i + 7, j + 2).Value = totalRC(i, j)
                Else
                    ThisWorkbook.Sheets(g).Cells(i + 1, j + 1).Value = totalRC(i, j)
                End If
             Next
         Next
    Next
    MsgBox "运行结束"
End Sub

最后接着不要操作电脑，等待程序弹出窗口通知。