Excel VBA：将多张工作表复制到新工作簿中答案

【问题标题】：Excel VBA: Copying multiple sheets into new workbookExcel VBA：将多张工作表复制到新工作簿中
【发布时间】：2014-01-03 12:00:40
【问题描述】：

当我运行这个子程序时，我收到一条“需要对象”的错误消息。我有一个用于复制每个特定工作表的版本，效果很好，但是这个子程序适用于 WB 内的所有工作表，即复制每个人的 WholePrintArea 并将其粘贴到新 WB 中的新工作表中。谢谢...

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

【问题讨论】：

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

标签： vba excel

【解决方案1】：

尝试这样做（问题是您尝试使用MyBook.Worksheets，但MyBook 不是Workbook 对象，而是string，包含工作簿名称。我添加了新变量@987654325 @，所以你可以用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

但是您的代码并没有按照您的意愿行事：它不会将某些内容复制到新的 WB。所以，下面的代码为你做：

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

【讨论】：

非常感谢 - 但我有一个问题，这仅适用于第一张纸，然后产生“订阅超出范围”错误消息。此外，我的名为“WholePrintArea”的范围肯定存在问题，因为某些工作表确实具有不同的 Print_Area，因此我尝试在此处插入：。
所以，我猜是因为sh.Range("WholePrintArea").Copy 行发生了错误。第一张纸的范围为WholePrintArea，但第二张纸没有。请告诉我，您的代码的主要思想是什么？我的意思是，您希望您的代码能为您做什么？
非常感谢 - 但我有一个问题，即只有在我使用“sh.copy”（即没有范围）时才有效，即使如此，也仅适用于产生“Subscrpt out of range”错误的第一张工作表信息。此外，我的名为“WholePrintArea”的范围肯定存在问题，因为某些工作表的打印区域确实不同，所以我尝试插入“sh.Range(Print_Area).Copy”，但这会产生一个 400 代码，暗示范围名称确实即使存在也不存在。
我已经更新了我的答案，因此它解决了“订阅超出范围”错误消息的问题
代码是创建一个新的 WB，将不同的打印区域从每个源图纸复制到新的 WB 中并使用相同的图纸名称。源 WB 具有打印区域之外的数据（使用文件 > 打印区域 > 设置打印区域进行设置），这些数据不会被复制。如果需要，我可以命名每张纸和每个打印区域，但有 19 个。

【解决方案2】：

重新考虑您的方法。为什么只复制表格的一部分？您指的是一个不存在的命名范围“WholePrintArea”。你也不应该在你的脚本中使用激活、选择、复制或粘贴。这些使“脚本”容易受到用户操作和其他同时执行的影响。在最坏的情况下，数据最终会落入坏人之手。

【讨论】：

【解决方案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

【讨论】：