VBA常用小代码208：复制指定文件夹下多工作簿的工作表到汇总工作簿

爱过的心没有任何讲求 许多故事有伤心的理由 这一次我的爱情等不到天长地久 走过的路再也不能停留……

诸君，都好啊，今天和大家分享的内容是，复制移动指定文件夹下名称符合条件的多个工作表到汇总工作簿。

举个例子，比如需要查找文件夹名称“EH论坛”下的多个工作簿，工作表名称包含“看见星光”的，将整份表格移动到汇总工作簿，并将其名称修改为“原工作簿名-工作表名”的形式，就可以使用下面的代码了。。。。嗯，代码是移动符合条件的工作表到目标工作簿，而不是复制数据到汇总表哦~

Sub CltSheets()

Dim P$, Bookn$, Book$, Keystr1, Keystr2, Shtname$, K&

Dim Sht As Worksheet, Sh As Worksheet

On Error Resume Next

With Application.FileDialog(msoFileDialogFolderPicker)

.AllowMultiSelect = False

If .Show Then P = .SelectedItems(1) Else: Exit Sub

End With

If Right(P, 1) "\" Then P = P & "\"

Keystr1 = InputBox("请输入工作簿名称所包含的关键词。" & vbCr & "关键词可以为空，如为空，则默认选择全部工作簿")

If StrPtr(Keystr1) = 0 Then Exit Sub'如果用户点击了取消或关闭按钮，则退出程序

Keystr2 = InputBox("请输入工作表名称所包含的关键词。" & vbCr & "关键词可以为空，如为空，则默认选择符合条件工作簿的全部工作表")

If StrPtr(Keystr2) = 0 Then Exit Sub

Set Sh = ActiveSheet'当前工作表，赋值变量,代码运行完毕后，回到此表

Bookn = Dir(P & "*.xls*")

Application.ScreenUpdating = False

Application.DisplayAlerts = False

Do While Bookn ""

If Bookn = ThisWorkbook.Name Then

MsgBox "注意：指定文件夹中存在和当前表格重名的工作簿！！" & vbCr & "该工作簿无法打开，工作表无法复制。"

'当出现重名工作簿时，提醒用户。

Else

If InStr(1, Bookn, Keystr1, vbTextCompare) Then

'工作簿名称是否包含关键词，关键词不区分大小写

With GetObject(P & Bookn)

For Each Sht In .Worksheets

If InStr(1, Sht.Name, Keystr2, vbTextCompare) Then

'工作表名称是否包含关键词，关键词不区分大小写

If Application.CountIf(Sht.UsedRange, "") Then

'如果表格存在数据区域

Shtname = Split(Bookn, ".xls")(0) & "-" & Sht.Name

'复制来的工作表以"工作簿-工作表"形式起名。

ThisWorkbook.Sheets(Shtname).Delete

'如果已存在相关表名，则删除

Sht.Copy after:=ThisWorkbook.Worksheets(Sheets.Count)

K = K + 1

'复制Sht到代码所在工作簿所有工作表的后面，并累计个数

ActiveSheet.Name = Shtname

'工作表命名。

End If

End If

Next

.Close False'关闭工作簿

End With

End If

End If

Bookn = Dir'下一个符合条件的文件

Loop

Sh.Select'回到初始工作表

MsgBox "工作表收集完毕，共收集：" & K & "个"

Application.ScreenUpdating = True

Application.DisplayAlerts = True

End Sub

操作说明：

代码运行后，会先弹出一个对话框，选择指定的文件夹。

选择目标文件夹后，单击确定。

工作簿关键词对话框，输入需要汇总的工作簿所包含的关键词，关键词不区分字母大小写，如果不输入关键词直接确定，则默认汇总指定文件夹下所有工作簿。

工作表关键词对话框，输入需要汇总的工作表所包含的关键词，关键词不区分字母大小写，如果不输入关键词直接确定，则默认汇总符合条件工作簿下所有包含数据的工作表。

代码运行完毕后，会提示一共汇总了几个工作表。

小贴士：

1，当指定文件夹下有和代码所在工作簿重名的工作簿时，代码会作出提醒。由于系统不允许同时打开两个同名工作簿，因此该工作簿下的工作表无法移动复制~

2，03版的工作表可以复制到07及以上版本的excel，但07及以上版本的excel工作表无法复制到03版，这是由于07等高级版本的excel拥有的行列远远多于03版，以致后者无法容纳前者。

更多常用VBA小代码，请持续关注本公众号：VBA编程学习与实践。握爪，致安。

……

一码不扫，

可以扫天下？

ExcelHome

VBA编程学习与实践