如何使用vba將工作表復制到另一個工作簿？

Question

所以，我想要做的，通常是制作一份工作簿的副本。 但是，源工作簿正在運行我的宏，我希望它制作自己的相同副本，但沒有宏。 我覺得應該有一種簡單的方法可以用 VBA 做到這一點，但還沒有找到。 我正在考慮將工作表一張一張地復制到我將創建的新工作簿中。 我該怎么做？ 有沒有更好的辦法？

Answer 1

我想稍微改寫 keytarhero 的回復：

Sub CopyWorkbook()

Dim sh as Worksheet,  wb as workbook

Set wb = workbooks("Target workbook")
For Each sh in workbooks("source workbook").Worksheets
   sh.Copy After:=wb.Sheets(wb.sheets.count) 
Next sh

End Sub

---

編輯：您還可以構建一個工作表名稱數組並立即復制。

Workbooks("source workbook").Worksheets(Array("sheet1","sheet2")).Copy _
         After:=wb.Sheets(wb.sheets.count)

注意：從 XLS 復制工作表？ XLS 將導致錯誤。 相反的工作正常（XLS 到 XLSX）

Answer 2

Ozgrid 的某 個人回答了類似的問題。 基本上，您只需將每個工作表一次從 Workbook1 復制到 Workbook2。

Sub CopyWorkbook()

    Dim currentSheet as Worksheet
    Dim sheetIndex as Integer
    sheetIndex = 1

    For Each currentSheet in Worksheets

        Windows("SOURCE WORKBOOK").Activate 
        currentSheet.Select
        currentSheet.Copy Before:=Workbooks("TARGET WORKBOOK").Sheets(sheetIndex) 

        sheetIndex = sheetIndex + 1

    Next currentSheet

End Sub

免責聲明：我還沒有嘗試過這段代碼，而是采用了鏈接示例來解決您的問題。 如果不出意外，它應該會引導您走向預期的解決方案。

Answer 3

你可以另存為 xlsx。 然后，您將松開宏並以更少的工作生成一個新的工作簿。

ThisWorkbook.saveas Filename:=NewFileNameWithPath, Format:=xlOpenXMLWorkbook

Answer 4

我能夠將運行 vba 應用程序的工作簿中的所有工作表復制到沒有應用程序宏的新工作簿中，使用：

ActiveWorkbook.Sheets.Copy

Answer 5

試試這個。

Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
    ws.Copy
Next

Answer 6

你可以簡單地寫

Worksheets.Copy

代替運行一個循環。 默認情況下，工作表集合會在新工作簿中重現。

它被證明可以在 2010 版的 XL 中運行。

Answer 7

假設你所有的宏都在模塊中，也許這個鏈接會有所幫助。 復制工作簿后，只需遍歷每個模塊並刪除它

Answer 8

    Workbooks.Open Filename:="Path(Ex: C:\Reports\ClientWiseReport.xls)"ReadOnly:=True


    For Each Sheet In ActiveWorkbook.Sheets

        Sheet.Copy After:=ThisWorkbook.Sheets(1)

    Next Sheet

Answer 9

這是您可能喜歡的一個，它使用 Windows FileDialog(msoFileDialogFilePicker) 瀏覽到桌面上已關閉的工作簿，然后將所有工作表復制到打開的工作簿中：

Sub CopyWorkBookFullv2()
Application.ScreenUpdating = False

Dim ws As Worksheet
Dim x As Integer
Dim closedBook As Workbook
Dim cell As Range
Dim numSheets As Integer
Dim LString As String
Dim LArray() As String
Dim dashpos As Long
Dim FileName As String

numSheets = 0

For Each ws In Application.ActiveWorkbook.Worksheets
    If ws.Name <> "Sheet1" Then
       Sheets.Add.Name = "Sheet1"
   End If
Next

Dim fileExplorer As FileDialog
Set fileExplorer = Application.FileDialog(msoFileDialogFilePicker)
Dim MyString As String

fileExplorer.AllowMultiSelect = False

  With fileExplorer
     If .Show = -1 Then 'Any file is selected
     MyString = .SelectedItems.Item(1)

     Else ' else dialog is cancelled
        MsgBox "You have cancelled the dialogue"
        [filePath] = "" ' when cancelled set blank as file path.
        End If
    End With

    LString = Range("A1").Value
    dashpos = InStr(1, LString, "\") + 1
    LArray = Split(LString, "\")
    'MsgBox LArray(dashpos - 1)
    FileName = LArray(dashpos)

strFileName = CreateObject("WScript.Shell").specialfolders("Desktop") & "\" & FileName

Set closedBook = Workbooks.Open(strFileName)
closedBook.Application.ScreenUpdating = False
numSheets = closedBook.Sheets.Count

        For x = 1 To numSheets
            closedBook.Sheets(x).Copy After:=ThisWorkbook.Sheets(1)
        x = x + 1
                 If x = numSheets Then
                    GoTo 1000
                 End If
Next

1000

closedBook.Application.ScreenUpdating = True
closedBook.Close
Application.ScreenUpdating = True

End Sub

Answer 10

試試這個

子 Get_Data_From_File()

     'Note: In the Regional Project that's coming up we learn how to import data from multiple Excel workbooks
    ' Also see BONUS sub procedure below (Bonus_Get_Data_From_File_InputBox()) that expands on this by inlcuding an input box
    Dim FileToOpen As Variant
    Dim OpenBook As Workbook
    Application.ScreenUpdating = False
    FileToOpen = Application.GetOpenFilename(Title:="Browse for your File & Import Range", FileFilter:="Excel Files (*.xls*),*xls*")
    If FileToOpen <> False Then
        Set OpenBook = Application.Workbooks.Open(FileToOpen)
         'copy data from A1 to E20 from first sheet
        OpenBook.Sheets(1).Range("A1:E20").Copy
        ThisWorkbook.Worksheets("SelectFile").Range("A10").PasteSpecial xlPasteValues
        OpenBook.Close False
        
    End If
    Application.ScreenUpdating = True
End Sub

或者這個：

Get_Data_From_File_InputBox()

Dim FileToOpen As Variant
Dim OpenBook As Workbook
Dim ShName As String
Dim Sh As Worksheet
On Error GoTo Handle:

FileToOpen = Application.GetOpenFilename(Title:="Browse for your File & Import Range", FileFilter:="Excel Files (*.xls*),*.xls*")
Application.ScreenUpdating = False
Application.DisplayAlerts = False

If FileToOpen <> False Then
    Set OpenBook = Application.Workbooks.Open(FileToOpen)
    ShName = Application.InputBox("Enter the sheet name to copy", "Enter the sheet name to copy")
    For Each Sh In OpenBook.Worksheets
        If UCase(Sh.Name) Like "*" & UCase(ShName) & "*" Then
            ShName = Sh.Name
        End If
    Next Sh

    'copy data from the specified sheet to this workbook - updae range as you see fit
    OpenBook.Sheets(ShName).Range("A1:CF1100").Copy
    ThisWorkbook.ActiveSheet.Range("A10").PasteSpecial xlPasteValues
    OpenBook.Close False
End If
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Exit Sub

句柄：If Err.Number = 9 Then MsgBox "工作表名稱不存在。請檢查拼寫" Else MsgBox "發生錯誤。 End If OpenBook.Close False Application.ScreenUpdating = True Application.DisplayAlerts = True End Sub

兩者都作為