网站开发在线测试平台/厦门专业做优化的公司

原创作者： 卢子 转自： Excel不加班

一年前的旧文章了，今天突然VIP学员需要这个功能，拿出来完善。原文章可以实现一键将多个工作簿合并成多个工作表，不过工作表名称没有重新改名。

详见：一键合并，12个增值税发票的工作簿

比如，文件夹内有很多工作簿，现在需要将所有工作簿放在Excel不加班教程合并这个工作簿。

合并后效果：工作表的名称是以原来工作簿的名称命名，每个工作表放着原来工作簿的内容。

将模板放在实际要合并的文件夹内，打开模板，运行即可。短短几秒钟，就将所有工作簿合并过来。

源代码：

Sub 合并工作簿()

Dim Wb As Workbook, MyPath As String, File, Sh_n As String

Application.ScreenUpdating = False

Rem 关闭屏幕刷新

MyPath$ = ThisWorkbook.Path & ""

Rem 获取当前工作簿路径

File = Dir(MyPath & "*.xls*")

Rem 获取路径下所有Excel文件

Do While File <> "" '遍历所有文件

If File <> ThisWorkbook.Name Then '不合并当前工作簿

Set Wb = Workbooks.Open(MyPath & File)

Rem 依次打开工作簿

Sh_n = StrReverse(Mid(StrReverse(Wb.Name), InStr(StrReverse(Wb.Name), ".") + 1))

Sheets(1).Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)

ActiveSheet.Name = Sh_n

Rem 将第一个表复制到当前工作簿的最后一个工作表

Wb.Close False '关闭工作簿 不保存

End If

File = Dir

Rem 循环下一个工作簿

Loop

Application.ScreenUpdating = False

Rem 打开屏幕刷

End Sub