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

Excel VBA: Copying multiple sheets into new workbook

提问by user3157086

I have an error message of 'Object Required' when I run this sub. I have a version for copying each specific sheet, which works fine, but this sub is for all sheets within the WB ie to copy each one's WholePrintArea and paste it into a new sheet in the new WB. Thanks...

当我运行这个子时，我有一条“需要对象”的错误消息。我有一个用于复制每个特定工作表的版本，效果很好，但是这个子文件适用于 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

回答by Dmitry Pavliv

Try do something like this (the problem was that you trying to use MyBook.Worksheets, but MyBookis not a Workbookobject, but string, containing workbook name. I've added new varible Set WB = ActiveWorkbook, so you can use WB.Worksheetsinstead MyBook.Worksheets):

尝试做这样的事情（的问题是，你试图使用MyBook.Worksheets，但MyBook不是一个Workbook对象，但是string，包含工作簿的名称我已经添加了新的varible。 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

But your code doesn't do what you want: it doesen't copy something to a new WB. So, the code below do it for you:

但是您的代码没有做您想要的：它不会将某些内容复制到新的 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

回答by user3157086

This worked for me (I added an "if sheet visible" because in my case I wanted to skip hidden sheets)

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

   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

回答by jumxozizi

Rethink your approach. Why would you copy only part of the sheet? You are referring to a named range "WholePrintArea" which doesn't exist. Also you should never use activate, select, copy or paste in your script. These make the "script" vulnerable to user actions and other simultaneous executions. In worst case scenario data ends up in wrong hands.

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