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

Question

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...

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

Answer 1

Try do something like this (the problem was that you trying to use MyBook.Worksheets , but MyBook is not a Workbook object, but string , containing workbook name. I've added new varible Set WB = ActiveWorkbook , so you can use WB.Worksheets instead 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:

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

Answer 2

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.

Answer 3

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

Answer 4

Since you are copying all worksheet, how about:

Copy & Paste (X) SaveAS (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

I had a worksheet "Control" handling all variant, you may change it yourself

Answer 5

On the other hand, if you really wish to use COPY & PASTE, you could use ARRAY

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

Remember to Dim (FolderPath,ExcelName,ExcelOrigin) as String As equal them to your file name & file path [ i can't type in those here because of error ]