VBA 复制多个工作簿中的所有工作表

Question

我正在尝试制作一个 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, Len(file) - 5), "("))
        '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 方面不太擅长，所以也欢迎任何解释:)

Answer 1

如果您希望该功能在您的 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

VBA 复制多个工作簿中的所有工作表

VBA to copy all sheets from multiple workbooks

excel

vba

getopenfilename