爱过的心没有任何讲求 许多故事有伤心的理由 这一次我的爱情等不到天长地久 走过的路再也不能停留……
诸君都好啊，今天和大家分享的内容是，移动复制指定文件夹下名称符合条件的多个工作表到汇总工作簿。
举个例子，比如需要查找文件夹名称“EH论坛”下的多个工作簿，工作表名称包含“看见星光”的，将整份表格移动到汇总工作簿，并将其名称修改为“原工作簿名-工作表名”的形式，就可以使用下面的代码了。。。。嗯，代码是移动符合条件的工作表到目标工作簿，而不是复制数据到汇总表哦~
Sub CltSheets() 'ExcelHome技术论坛公众号：VBA编程学习与实践，看见星光 Dim strPath$, strBookName$, strKey1, strKey2, strShtName$, k& Dim sht As Worksheet, shtActive As Worksheet On Error Resume Next With Application.FileDialog(msoFileDialogFolderPicker) If .Show Then strPath = .SelectedItems(1) Else: Exit Sub End With If Right(strPath, 1) "\" Then strPath = strPath & "\" strKey1 = InputBox("请输入工作簿名称所包含的关键词。" & vbCr & "关键词可以为空，如为空，则默认选择全部工作簿") If StrPtr(strKey1) = 0 Then Exit Sub '如果用户点击了取消或关闭按钮，则退出程序 strKey2 = InputBox("请输入工作表名称所包含的关键词。" & vbCr & "关键词可以为空，如为空，则默认选择符合条件工作簿的全部工作表") If StrPtr(strKey2) = 0 Then Exit Sub Set shtActive = ActiveSheet '当前工作表，赋值变量,代码运行完毕后，回到此表 strBookName = Dir(strPath & "*.xls*") Application.ScreenUpdating = False Application.DisplayAlerts = False Do While strBookName "" If strBookName = ThisWorkbook.Name Then MsgBox "注意：指定文件夹中存在和当前表格重名的工作簿！！" & vbCr & "该工作簿无法打开，工作表无法复制。" '当出现重名工作簿时，提醒用户。 Else If InStr(1, strBookName, strKey1, vbTextCompare) Then '工作簿名称是否包含关键词，关键词不区分大小写 With GetObject(strPath & strBookName) For Each sht In .Worksheets If InStr(1, sht.Name, strKey2, vbTextCompare) Then '工作表名称是否包含关键词，关键词不区分大小写 If Application.CountIf(sht.UsedRange, "") Then '如果表格存在数据区域 strShtName = Split(strBookName, ".xls")(0) & "-" & sht.Name '复制来的工作表以"工作簿-工作表"形式起名。 ThisWorkbook.Sheets(strShtName).Delete '如果已存在相关表名，则删除 sht.Copy after:=ThisWorkbook.Worksheets(Sheets.Count) k = k + 1 '复制Sht到代码所在工作簿所有工作表的后面，并累计个数 ActiveSheet.Name = strShtName '工作表命名。 End If End If Next .Close False '关闭工作簿 End With End If End If strBookName = Dir '下一个符合条件的文件 Loop shtActive.Select '回到初始工作表 MsgBox "工作表收集完毕，共收集：" & k & "个" Application.ScreenUpdating = True Application.DisplayAlerts = TrueEnd Sub
操作说明：
代码运行后，会先弹出一个对话框，选择指定的文件夹。
![]()
选择目标文件夹后，单击确定。
工作簿关键词对话框，输入需要汇总的工作簿所包含的关键词，关键词不区分字母大小写，如果不输入关键词直接确定，则默认汇总指定文件夹下所有工作簿。
![]()
工作表关键词对话框，输入需要汇总的工作表所包含的关键词，关键词不区分字母大小写，如果不输入关键词直接确定，则默认汇总符合条件工作簿下所有包含数据的工作表。
![]()
代码运行完毕后，会提示一共汇总了几个工作表。
![]()
小贴士：
1，当指定文件夹下有和代码所在工作簿重名的工作簿时，代码会作出提醒。由于系统不允许同时打开两个同名工作簿，因此该工作簿下的工作表无法移动复制~
![]()
2，03版的工作表可以复制到07及以上版本的excel，但07及以上版本的excel工作表无法复制到03版，这是由于07等高级版本的excel拥有的行列远远多于03版，以致后者无法容纳前者。
更多常用VBA小代码，请持续关注本公众号：VBA编程学习与实践。握爪，致安。
……
![]()
![]()
![]()
一码不扫，
可以扫天下？
ExcelHome
VBA编程学习与实践
|
|
转播
