诸君都好啊,今天和大家分享的内容是,移动复制指定文件夹下名称符合条件的多个工作表到汇总工作簿。
举个例子,比如需要查找文件夹名称“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编程学习与实践。握爪,致安。
联系客服