Excel VBA: 将多个工作表复制到新工作簿中

Question

当我运行这个子程序时，出现了“对象所需”的错误消息。 我有一个版本可以复制每个特定工作表，这个版本很好用，但是这个子程序适用于WB中的所有工作表，即将每个工作表的WholePrintArea复制并粘贴到新工作簿中的新工作表中。谢谢...

Sub NewWBandPasteSpecialALLSheets()

  MyBook = ActiveWorkbook.Name ' Get name of this book
  Workbooks.Add ' Open a new workbook
  NewBook = ActiveWorkbook.Name ' Save name of new book

  Workbooks(MyBook).Activate ' Back to original book

  Dim SH As Worksheet

    For Each SH In MyBook.Worksheets

    SH.Range("WholePrintArea").Copy

    Workbooks(NewBook).Activate

        With SH.Range("A1")
            .PasteSpecial (xlPasteColumnWidths)
            .PasteSpecial (xlFormats)
            .PasteSpecial (xlValues)

        End With

    Next

End Sub

- user3157086

---

除了变量声明错误之外，您是否试图将每个工作表的打印区域复制粘贴到相同的Range（A1）中？ 我以为你在尝试粘贴到一个新的工作簿中。 - PatricK

Answer 1

尝试像这样做（问题在于您试图使用MyBook.Worksheets，但MyBook不是Workbook对象，而是包含工作簿名称的string。我添加了新变量Set WB = ActiveWorkbook，因此您可以使用WB.Worksheets代替MyBook.Worksheets）：

Sub NewWBandPasteSpecialALLSheets()
   MyBook = ActiveWorkbook.Name ' Get name of this book
   Workbooks.Add ' Open a new workbook
   NewBook = ActiveWorkbook.Name ' Save name of new book

   Workbooks(MyBook).Activate ' Back to original book

   Set WB = ActiveWorkbook

   Dim SH As Worksheet

   For Each SH In WB.Worksheets

       SH.Range("WholePrintArea").Copy

       Workbooks(NewBook).Activate

       With SH.Range("A1")
        .PasteSpecial (xlPasteColumnWidths)
        .PasteSpecial (xlFormats)
        .PasteSpecial (xlValues)

       End With

     Next

End Sub

但是你的代码并没有达到想要的效果：它没有将某些内容复制到新的工作簿中。因此，下面的代码可以为您完成此操作：

Sub NewWBandPasteSpecialALLSheets()
   Dim wb As Workbook
   Dim wbNew As Workbook
   Dim sh As Worksheet
   Dim shNew As Worksheet

   Set wb = ThisWorkbook
   Workbooks.Add ' Open a new workbook
   Set wbNew = ActiveWorkbook

   On Error Resume Next

   For Each sh In wb.Worksheets
      sh.Range("WholePrintArea").Copy

      'add new sheet into new workbook with the same name
      With wbNew.Worksheets

          Set shNew = Nothing
          Set shNew = .Item(sh.Name)

          If shNew Is Nothing Then
              .Add After:=.Item(.Count)
              .Item(.Count).Name = sh.Name
              Set shNew = .Item(.Count)
          End If
      End With

      With shNew.Range("A1")
          .PasteSpecial (xlPasteColumnWidths)
          .PasteSpecial (xlFormats)
          .PasteSpecial (xlValues)
      End With
   Next
End Sub

- Dmitry Pavliv

---

所以，我猜测错误是因为这一行代码 sh.Range("WholePrintArea").Copy。第一个工作表有范围 WholePrintArea，但第二个工作表没有。请告诉我，你的代码的主要思想是什么？我的意思是，你希望你的代码为你做什么？ - Dmitry Pavliv

非常感谢 - 但我有一个问题，这只在我使用"sh.copy"时才有效，即没有范围，即使如此，仅对第一个工作表有效，会产生“下标超出范围”的错误消息。此外，我的名为“WholePrintArea”的范围肯定存在问题，因为某些工作表具有不同的打印区域，因此我尝试插入“sh.Range(Print_Area).Copy”，但这会产生400代码，表示范围名称不存在，即使它确实存在。 - user3157086

我已经更新了我的答案，因此修复了“下标超出范围”的错误消息问题。 - Dmitry Pavliv

在循环 For Each sh In wb.Worksheets 中，您可以添加类似于 sh.PageSetup.PrintArea = "$A$1:$X100" 的内容，这样它就会将“Print_Area”范围添加到您的工作表中。然后，您可以使用 sh.Range("Print_Area").Copy。 - Dmitry Pavliv

非常感谢您的时间和智慧。 - user3157086

Answer 2

重新思考你的方法。为什么只复制表格的部分呢？你正在引用一个不存在的命名区域“WholePrintArea”。另外，你不应该在脚本中使用activate、select、copy或paste。这些操作会使“脚本”容易受到用户操作和其他同时执行的影响。在最严重的情况下，数据可能会落入错误的手中。

- jumxozizi

Answer 3

这对我有用（我添加了一个“如果工作表可见”的条件，因为在我的情况下，我想跳过隐藏的工作表）

   Sub Create_new_file()

Application.DisplayAlerts = False

Dim wb As Workbook
Dim wbNew As Workbook
Dim sh As Worksheet
Dim shNew As Worksheet
Dim pname, parea As String


Set wb = ThisWorkbook
Workbooks.Add
Set wbNew = ActiveWorkbook

For Each sh In wb.Worksheets

    pname = sh.Name


    If sh.Visible = True Then

    sh.Copy After:=wbNew.Sheets(Sheets.Count)

    wbNew.Sheets(Sheets.Count).Cells.ClearContents
    wbNew.Sheets(Sheets.Count).Cells.ClearFormats
    wb.Sheets(sh.Name).Activate
    Range(sh.PageSetup.PrintArea).Select
    Selection.Copy

    wbNew.Sheets(pname).Activate
    Range("A1").Select

    With Selection

        .PasteSpecial (xlValues)
        .PasteSpecial (xlFormats)
        .PasteSpecial (xlPasteColumnWidths)

    End With

    ActiveSheet.Name = pname

    End If


Next

wbNew.Sheets("Hoja1").Delete

Application.DisplayAlerts = True

End Sub

- user8608712

Answer 4

另一方面，如果你真的希望使用复制和粘贴，你可以使用数组

Workbooks.Add
ActiveWorkbook.SaveAs Filename:=FolderPath & ExcelName & ".xlsx", FileFormat:=xlNormal

Workbooks(ExcelOrigin).Activate
    Sheets(Array("for coversheet", "Pivot", "CCA", "FRR", "CRS", "GSA", "Inv Summary", "UploadtoJDE", "Comat")).Copy Before:=Workbooks(ExcelName).Sheets(1)
Sheets("Sheet1").Delete

记得将 FolderPath、ExcelName、ExcelOrigin 声明为字符串类型，并将它们赋值为你的文件路径和文件名。 [由于错误，我无法在这里键入它们]

- Ho Wai Yan Arthur

Answer 5

既然你要复制所有工作表，那么如何考虑：

复制并粘贴（X） 另存为（O）

Sub Export()

Application.DisplayAlerts = False
On Error Resume Next

Dim NewWB As String

NewWB = Sheets("Control").Range("B42")

ActiveWorkbook.SaveAs Filename:=NewWB, FileFormat:=xlWorkbookNormal
ActiveWorkbook.Sheets("Control").Delete

End Sub

我有一个名为“控制”的工作表来处理所有的变量，你可以自己更改

- Ho Wai Yan Arthur