|
诸君都好啊，今天和大家分享的内容是，移动复制指定文件夹下名称符合条件的多个工作表到汇总工作簿。 举个例子，比如需要查找文件夹名称“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 = True
End Sub 操作说明： 代码运行后，会先弹出一个对话框，选择指定的文件夹。
选择目标文件夹后，单击确定。 工作簿关键词对话框，输入需要汇总的工作簿所包含的关键词，关键词不区分字母大小写，如果不输入关键词直接确定，则默认汇总指定文件夹下所有工作簿。 
工作表关键词对话框，输入需要汇总的工作表所包含的关键词，关键词不区分字母大小写，如果不输入关键词直接确定，则默认汇总符合条件工作簿下所有包含数据的工作表。 
代码运行完毕后，会提示一共汇总了几个工作表。
小贴士： 1，当指定文件夹下有和代码所在工作簿重名的工作簿时，代码会作出提醒。由于系统不允许同时打开两个同名工作簿，因此该工作簿下的工作表无法移动复制~
2，03版的工作表可以复制到07及以上版本的excel，但07及以上版本的excel工作表无法复制到03版，这是由于07等高级版本的excel拥有的行列远远多于03版，以致后者无法容纳前者。 更多常用VBA小代码，请持续关注本公众号：VBA编程学习与实践。握爪，致安。
|
