用VBA合并计算Excel多个工作簿及工作表

因为有人询问合并计算，对VBA略知一些，我就写了一点，有需要的人可以借鉴。

新建一个工作表，粘贴到模块，F5运行，就可以达到左列合计，左列为一列。

下面是代码：

无源数据格式

Sub 多工作簿合计()
Application.ScreenUpdating = False
Dim Wb As Workbook, vrtSelectedItem As Variant, Mysheet As Worksheet, CellAddress
Dim ShRan As String, Arr() As String, s As Long, Spt, NewPath As String, Bool As Boolean
On Error Resume Next '遇到错误继续执行
With Application.FileDialog(msoFileDialogFilePicker)
   .AllowMultiSelect = True
   '多选
  .InitialFileName = ThisWorkbook.Path & "\"
  '默认路径
  .Title = "选择文件"
  '窗口标题
  .Filters.Clear
   '清除文件过滤器
  .Filters.Add "全部文件", "*.*"
  .Filters.Add "Excel文件", "*.xlsm"
  .Filters.Add "Excel文件", "*.xls"
  .Filters.Add "Excel文件", "*.xlsx;*.xls"
   '设置文件过滤器，可以指定多个扩展名，每个扩展名都必须用分号分隔。 例如，可以将参数分配给字符串：".txt;.htm"。
  Cells.Clear
  Bool = True
  If .Show = -1 Then
    For Each vrtSelectedItem In .SelectedItems
      Spt = Split(vrtSelectedItem, "\")
      NewPath = "'" & Replace(vrtSelectedItem, Spt(UBound(Spt)), "[" & Spt(UBound(Spt)) & "]")
      Set Wb = Workbooks.Open(vrtSelectedItem)
      For Each Mysheet In Wb.Worksheets
        '复制标题行，不带格式粘贴
        If Bool Then
          Mysheet.Rows("1:1").Copy
          Cells(1, 1).PasteSpecial Paste:=xlPasteValues
          Bool = False
          Application.CutCopyMode = False
        End If
        ReDim Preserve Arr(s)
        '获取不包含首行的当前区域
        CellAddress = Split(Mysheet.Cells(2, 1).CurrentRegion.Address, ":")
        ShRan = Mysheet.Name & "'!" & Mysheet.Range("A2：" & CellAddress(1)).Address(ReferenceStyle:=xlR1C1) '数据区域
        Arr(s) = NewPath & ShRan
        s = s + 1
      Next Mysheet
      Wb.Close
    Next vrtSelectedItem
    Set Wb = Nothing
  End If
End With
Range("A2").Consolidate Sources:=Arr, Function:=xlSum, TopRow:=False, LeftColumn:=True, CreateLinks:=False
Application.ScreenUpdating = True
End Sub

下面是有源数据格式的

Sub 汇总合计() '保留源数据格式
Application.ScreenUpdating = False
Dim Wb As Workbook, vrtSelectedItem, Mysheet As Worksheet, i As Long, Bool As Boolean, Start_row
'On Error Resume Next '容错
With Application.FileDialog(msoFileDialogFilePicker)
  .AllowMultiSelect = True
   '多选
  .InitialFileName = ThisWorkbook.Path & "\"
  '默认路径
  .Title = "选择文件"
  '窗口标题
  .Filters.Clear
   '清除文件过滤器
  .Filters.Add "全部文件", "*.*"
  .Filters.Add "Excel文件", "*.xlsx;*.xls" '可以指定多个扩展名，每个扩展名都必须用分号分隔。 例如，可以将参数分配给字符串：".txt;.htm"。
  .Filters.Add "Excel文件", "*.xlsm"
  .Filters.Add "Excel文件", "*.xls"
  '设置文件过滤器
  
  Cells.Clear
  Bool = True
  If .Show = -1 Then
    For Each vrtSelectedItem In .SelectedItems
      Set Wb = Workbooks.Open(vrtSelectedItem)
      With ThisWorkbook.ActiveSheet
        For Each Mysheet In Wb.Worksheets
          If Bool = True Then Start_row = 1 Else Start_row = 2: Bool = False
          '获取不包含首行的当前区域
          CellAddress = Split(Mysheet.Cells(1, 1).CurrentRegion.Address, ":")
          Mysheet.Range("A" & Start_row & "：" & CellAddress(1)).Copy .Cells(i + 1, 1)
          
          i = Mysheet.Range("A1").CurrentRegion.Rows.Count
        Next
      End With
      Wb.Close
    Next
    Set Wb = Nothing
  End If
End With

Dim RowCount As Long, MyRange As String, ColCount As Long, DataCol As Long, E_Coords, Act_sh

With ThisWorkbook.ActiveSheet
    RowCount = .Cells(Rows.Count, 2).End(xlUp).Row
    ColCount = .Cells(1, 1).CurrentRegion.Columns.Count
    Act_sh = .Cells(1, 1).CurrentRegion.Address
    .Range(Act_sh).Copy
        With .Cells(1, ColCount + 1)
           .PasteSpecial Paste:=xlPasteColumnWidths
           .PasteSpecial Paste:=xlPasteFormats
        End With
    Application.CutCopyMode = False
    E_Coords = Split(Act_sh, ":")(1)
    MyRange = ActiveSheet.Name & "!" & .Range("A2:" & E_Coords).Address(ReferenceStyle:=xlR1C1)
    .Cells(2, ColCount + 1).Consolidate Sources:=MyRange, _
            Function:=xlSum, TopRow:=False, LeftColumn:=True, CreateLinks:=False
            
    .Range("A2:" & E_Coords).Delete Shift:=xlToLeft
  
    .Range(Range("A1").CurrentRegion.Rows.Count + 1 & ":" & .Cells.Rows.Count).ClearFormats
End With
Application.ScreenUpdating = True
End Sub