VBA：如何将指定文件夹下所有工作簿的工作表移动到当前工作簿？
HI，大家好，我是星光。Excel会员群里有朋友提了个问题：有一个文件夹，里面有很多工作簿，工作簿内又有很多工作表，现在需要将每张工作表移动到当前工作簿，有没有什么好的解法办法？——打个响指，当然是有的，文末提供了一个一键解决该问题的Excel模版，下载后单击命令按钮，稍等数秒，即可完成目标。
牵牵爪子，一起看个小视频，了解下模版运行过程和效果。
代码解析见注释
代码看不全可以左右拖动..▼
Sub GetSheetsCopy()
Dim strPath As String, strBookName As String, strKey As String
Dim strShtName As String, k As Long, wb As Workbook
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 & '\'
strKey = InputBox('请输入工作表名称所包含的关键词。' & vbCr _
& '关键词可以为空，如为空，则默认移动全部工作表')
If StrPtr(strKey) = 0 Then Exit Sub
Set shtActive = ActiveSheet '当前工作表，代码运行完毕后，回到此表
With Application
.ScreenUpdating = False
.DisplayAlerts = False
.AskToUpdateLinks = False
.Calculation = xlManual
End With
strBookName = Dir(strPath & '*.xls*')
Do While strBookName <> ''
If strBookName = ThisWorkbook.Name Then
MsgBox '注意：指定文件夹中存在和当前工作簿重名的工作簿！！' & vbCr & '该工作簿无法打开，工作表无法复制。' '当出现重名工作簿时，提醒用户。
Else
Set wb = Workbooks.Open(strPath & strBookName)
For Each sht In wb.Worksheets
If IsEmpty(sht.UsedRange) = False Then
If InStr(1, sht.Name, strKey, vbTextCompare) Then '工作表名称是否包含关键词，关键词不区分大小写
strShtName = Split(strBookName, '.xls')(0) & '-' & sht.Name '复制来的工作表以'工作簿-工作表'形式起名。
ThisWorkbook.Sheets(strShtName).Delete '如果已存在相关表名，则删除
sht.Copy after:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count) '复制到代码所在工作簿
k = k + 1 '复制Sht到代码所在工作簿所有工作表的后面，并累计个数
ActiveSheet.Name = strShtName '工作表命名
End If
End If
Next
wb.Close False '关闭工作簿，不保存
End If
strBookName = Dir '下一个符合条件的文件
Loop
shtActive.Select '回到初始工作表
MsgBox '工作表收集完毕，共收集：' & k & '个'
With Application
.ScreenUpdating = True
.DisplayAlerts = True
.AskToUpdateLinks = True
.Calculation = xlAutomatic
End With
End Sub
赞 (0)