如何使用 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

假设您所有的宏都在模块中，也许this link 会有所帮助。复制工作簿后，只需遍历每个模块并删除它

Answer 6

试试这个吧。

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

Answer 7

你可以简单地写

Worksheets.Copy

代替运行循环。 默认情况下，工作表集合会在新工作簿中复制。

在 2010 版本的 XL 中被证明可以正常工作。

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

试试这个

Sub 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

句柄： 如果 Err.Number = 9 那么 MsgBox "工作表名称不存在，请检查拼写" 别的 MsgBox "发生错误。" 万一 OpenBook.Close 错误 Application.ScreenUpdating = True Application.DisplayAlerts = True 结束子

两者都是