此宏解决的痛点:
多个表格字段相同,需要手工一个个打开之后复制合并到一个表上面的难题。
宏使用方式:
如下代码贴到VBE编辑器里后,不需任何修改即可直接使用。使用前确保要合并的Excel放置在同一个文件夹内,点击宏后,把存放Excel的文件夹的地址粘贴到弹出框即可。
示例:
1、待合并的EXCEL放在同一个文件夹内
2、使用宏,粘贴路径地址
3、大功告成
如下为代码
Sub 合并指定文件夹的工作簿()
Dim MP, MN, AW, Wbn, wn
Dim Wb As Workbook
Dim i, a, b, c, d, e
Application.ScreenUpdating = False
MP = InputBox("请输入需要合并的文件夹的地址,如D:")
Workbooks.Add
'遍历地址下所有拓展名含xls的文件
MN = Dir(MP & "" & "*.xls*")
'获取当前工作簿名称
AW = ActiveWorkbook.Name
Num = 0
e = 1
'一个一个的打开工作簿,只要打开了,就执行以下的命令
Do While MN <> ""
'如果工作簿和汇总的表格名称不一致,则执行以下的命令
If MN <> AW Then
Set Wb = Workbooks.Open(MP & "" & MN)
'计数现在汇总了几张表
a = a + 1
With Workbooks(AW).ActiveSheet
'确定当前工作簿有多少个工作表,一个一个的打开
For i = 1 To Sheets.Count
'如果工作表的A1单元格不为空,则执行如下语句
If Sheets(i).Range("A1") <> "" Then
'复制首行/表头
Wb.Sheets(i).Range("A1").Resize(1, Sheets(i).UsedRange.Columns.Count).Copy .Cells(1, 1)
'确定待复制的工作表总共有多少列
d = Wb.Sheets(i).UsedRange.Columns.Count
'确定待复制的工作表剔除表头有多少行
c = Wb.Sheets(i).UsedRange.Rows.Count - 1
'增加一列填入工作簿&工作表名
wn = Wb.Sheets(i).Name
.Cells(1, d + 1) = "表名"
.Cells(e + 1, d + 1).Resize(c, 1) = MN & wn
e = e + c
'复制表格信息到汇总表里
Wb.Sheets(i).Range("A2").Resize(c, d).Copy .Cells(.Range("A1048576").End(xlUp).Row + 1, 1)
End If
Next
'将刚打开的表格名和前面已汇总过的表格名组合起来
Wbn = Wbn & Chr(13) & Wb.Name
'关闭当前工作簿
Wb.Close False
End With
End If
MN = Dir
'循环
Loop
Range("A1").Select
Application.ScreenUpdating = True
MsgBox "共合并了" & a & "个工作簿下全部工作表。明细如下:" & Chr(13) & Wbn, vbInformation, "提示"
End Sub