一键将多个工作簿合并成多个工作表（完善版）
点击上方蓝字「Excel不加班」关注，看下一篇
恭喜下面3位幸运儿：Choicc、LGM海王星、土它@土它，获得书籍，加卢子微信chenxilu2019。
为了活跃气氛，在文末点亮“在看”+评论区留言，我会从中抽取3名粉丝，每人赠送一本《卢子Excel高手速成视频教程 早做完，不加班》。
复制下面这段内容，打开手机淘宝，即可购买。
付製这行话HVMT1Qm6JF8转移至淘宀┡ē，【【卢子2020新书】卢子Excel高手速成视频教程 excel函数公式大全 excel高级教程 电子表格excel教程书 表格制作 excel教程书籍】
一年前的旧文章了，今天突然VIP学员需要这个功能，拿出来完善。原文章可以实现一键将多个工作簿合并成多个工作表，不过工作表名称没有重新改名。
比如，文件夹内有很多工作簿，现在需要将所有工作簿放在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
链接：
https://pan.baidu.com/s/1vBehDA_8Z_DXS9NDgBgSTA
提取码：017c
复制这段内容后打开百度网盘手机App，操作更方便哦
VIP888元，一次报名，所有视频课程，终生免费学，提供一年在线答疑服务。
报名后加卢子微信chenxilu2019，发送报名截图邀请进群。
今天，又发现教程被别人盗版了。哎，互联网违法成本太低，盗版一个接一个，心累。原创真的不容易，一篇文章、一个视频基本上都要花2个小时左右，希望你能尊重一下原创作者，拒绝盗版。
作者：卢子，清华畅销书作者，《Excel效率手册 早做完，不加班》系列丛书创始人，个人公众号：Excel不加班（ID：Excelbujiaban）
请把「Excel不加班」推荐给你的朋友
无需打赏，请点在看↓↓↓