|
诸君晚上好。昨个星光大叔发烧了，无更，拥抱致歉先。 ……今个是点播时间，嘿~何谓点播时间？…… ……话说前两天有朋友在后台发消息问，能不能分享一期代码，将指定文件夹下，包含某个关键词的工作簿中的工作表，批量移动到当前工作簿？ 今天我们就分享解决此类问题的小代码。 是谓点播时间。哈哈~
1， 开门见山，代码如下： Sub CltSheets() 'ExcelHome技术论坛公众号：VBA编程学习与实践，作者看见星光 Dim P$, Bookn$, Book$, Keystr1, Keystr2, Shtname$, K& Dim Sht As Worksheet, Sh As Worksheet Application.ScreenUpdating = False Application.DisplayAlerts = False 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*') 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 2， 代码运行后，会先弹出一个对话框，选择指定的文件夹。 选择目标文件夹后，单击确定。 工作簿关键词对话框，输入需要汇总的工作簿所包含的关键词，关键词不区分字母大小写，如果不输入关键词直接确定，则默认汇总指定文件夹下所有工作簿。 工作表关键词对话框，输入需要汇总的工作表所包含的关键词，关键词不区分字母大小写，如果不输入关键词直接确定，则默认汇总符合条件工作簿下所有包含数据的工作表。 代码运行完毕后，会提示一共汇总了几个工作表。 小贴士： 当指定文件夹下有和代码所在工作簿重名的工作簿时，代码会作出提醒。由于系统不允许同时打开两个同名工作簿，因此该工作簿下的工作表无法移动复制~ 更多常用VBA小代码，请持续关注本公众号：VBA编程学习与实践。握爪，致安。 The End   一码不扫， ExcelHome VBA编程学习与实践 |
|
|
