用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

• « 上一篇：npm配置vue-cli所遇EACCES权限问题及解决方案
• » 下一篇：MySQL事务的操作