问题描述
我正在尝试制作一个可以打开多个工作簿（也只有一个）的 VBA，将它们的所有工作表复制到另一个工作簿中。我想让我的代码直接从 PersonalWorkbook 中运行，以便我可以在任何我想要的新工作簿中使用它。
我知道这不是很多，但我被这些不完整的版本卡住了（第二个根本没有按预期工作）...
Sub conso()
Dim folderpath As String
Dim file As String
Dim i As Long
folderpath = InputBox("Please paste the folder path","Choose Folder") & "\"
file = Dir(folderpath)
do while file <> ""
Workbooks.Open folderpath & file
ActiveWorkbook.Worksheets(1).copy after:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
'ActiveSheet.Name = Right(Left(file,Len(file) - 5),Len(Left(file,Len(file) - 5)) - InStr(1,Left(file,"("))
'ActiveSheet.Name = file
ActiveSheet.Name = Left(file,InStr(file,".") - 1)
Workbooks(file).Close
file = Dir()
Loop
End Sub
第二：
Sub open_and_copy_sheets()
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Dim my_FileName As Variant
Dim nm As String
Dim nm2 As String
Dim i As Integer
nm = ActiveWorkbook.Name
my_FileName = Application.GetopenFilename(FileFilter:="Excel Files,*.xl*;*.xm*")
If my_FileName <> False Then
Workbooks.Open Filename:=my_FileName
End If
Workbooks(Workbooks.Count).Activate
nm2 = ActiveWorkbook.Name
For i = 1 To Workbooks(nm2).Worksheets.Count
Sheets(i).copy after:=Workbooks(nm).Sheets(Workbooks(nm).Sheets.Count)
Next i
Workbooks(nm2).Close SaveChanges:=False
Workbooks(nm).Activate
Worksheets(1).Activate
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
任何帮助将不胜感激！我在 vba 方面不是很好，所以也欢迎任何解释:)
解决方法
如果您希望该功能在您的 PersonalWorkbook 中可用，请通过 VBA 编辑器在 Personal.XLSB 下创建一个“模块”（请参阅屏幕截图）。我稍微修正了你的代码：
Option Explicit
Sub test()
Dim destinationFile As Variant
Dim sourceWbk As Workbook
Dim destinationWbk As Workbook
Dim sheet As Worksheet
Dim index As Integer
Application.ScreenUpdating = False
Set sourceWbk = ActiveWorkbook
destinationFile = Application.GetOpenFilename(FileFilter:="Excel Files,*.xl*;*.xm*")
If destinationFile <> False Then
Workbooks.Open fileName:=destinationFile
Set destinationWbk = ActiveWorkbook
For Each sheet In sourceWbk.Sheets
sheet.Copy Before:=destinationWbk.Sheets(index)
index = index + 1
Next sheet
MsgBox (index & " sheets copied")
Else
MsgBox ("No file selected. Action aborted.")
End If
Set sheet = Nothing
Set sourceWbk = Nothing
Set destinationWbk = Nothing
Application.ScreenUpdating = True
End Sub
它比你之前的要紧凑一些，有一个或两个错误，而且即使没有选择目标工作簿，代码也会继续尝试复制。您只需要添加一行来保存最终的新工作簿（您可以使用“index”变量来查看它是否 > 1 作为检查是否有任何要保存的内容。“Option Explicit”是一个好主意在模块的顶部，它会检查您的代码以确保您使用的任何变量都已明确声明，这有助于避免输入错误。
更新这里是一个完整的解决方案：
你需要把它分解成单独的块才能得到你想要的。
第 1 步 - 询问用户他们是将工作表复制到单个文件还是多个文件：
Public Function MasterCopy()
Dim choice As Variant
choice = InputBox("Enter S or M:","Select whether to copy to a single or multiple sheets")
Select Case UCase(choice)
Case "S"
Call FncSingleFileCopy
Case "M"
Call FncMultiFileCopy
Case Else
MsgBox ("Cancelled.")
End Select
End Function
第 2 步：添加两个功能，一个用于复制倍数，一个用于单个：
Private Function FncMultiFileCopy()
Dim destinationFile As Variant
Dim sourceWbk As Workbook
Dim folderPath As String
Dim copied As Integer
Set sourceWbk = ActiveWorkbook
folderPath = InputBox("Please paste the folder path","Choose Folder")
If (folderPath) <> "" Then
folderPath = folderPath & "\"
destinationFile = Dir(folderPath)
Do While destinationFile <> ""
If InStr(destinationFile,".xls") > 1 Then
Call FncCopySheets(sourceWbk,folderPath & destinationFile)
End If
destinationFile = Dir()
Loop
MsgBox ("Finished.")
Else
MsgBox ("Cancelled.")
End If
Set sourceWbk = Nothing
End Function
Private Function FncSingleFileCopy()
Dim destinationFile As Variant
Dim sourceWbk As Workbook
Dim copied As Integer
Set sourceWbk = ActiveWorkbook
destinationFile = Application.GetOpenFilename(FileFilter:="Excel Files,*.xl*;*.xm*")
If destinationFile <> False Then
copied = FncCopySheets(sourceWbk,destinationFile)
MsgBox (copied & " sheets copied")
Else
MsgBox ("No file selected. Action aborted.")
End If
Set sourceWbk = Nothing
End Function
第 3 步：最后，使用源工作簿和目标文件复制工作表的函数，可以从前两个函数中的任何一个调用：
Private Function FncCopySheets(sourceWbk As Workbook,destinationFile As Variant) As Integer
Dim destinationWbk As Workbook
Dim sht As Worksheet
Dim shtsCopied As Integer
Application.ScreenUpdating = False
Set destinationWbk = Workbooks.Open(destinationFile)
For Each sht In sourceWbk.Sheets
sht.Copy Before:=destinationWbk.Sheets(1)
shtsCopied = shtsCopied + 1
Next sht
destinationWbk.Close (True)
Application.ScreenUpdating = True
FncCopySheets = shtsCopied
Set destinationWbk = Nothing
End Function