Copy multiple sheets to a new workbook

[sofas]

Welcome. I have a workbook consisting of several sheets. I want to copy all sheets to a new workbook ignoring only one sheet Sheet1, and save the new workbook in the same default path in xlsx format.

 

[NdNoviceHlp]

Hi sofas. You can trial this code. HTH. Dave

Sub test()
Dim Newbook As Object, SourceWorkbook As Object
Dim cnt As Integer, PageCollect As Collection, tempworksheet As Worksheet
Set SourceWorkbook = ThisWorkbook
Set PageCollect = New Collection

On Error GoTo ErrHandler
Application.ScreenUpdating = False
Application.DisplayAlerts = False

'add sheets to collection
For Each tempworksheet In SourceWorkbook.Worksheets
If SourceWorkbook.Sheets(tempworksheet.Name).Name <> "Sheet1" Then
PageCollect.Add SourceWorkbook.Sheets(tempworksheet.Name)
End If
Next tempworksheet

'add new wb. Transfer sheets. Save to same path with same name in .xlsx format
Set Newbook = Workbooks.Add
With Newbook
For cnt = 1 To PageCollect.Count
PageCollect(cnt).Copy After:=Newbook.Sheets(Newbook.Sheets.Count)
Next cnt
.SaveAs Filename:=ThisWorkbook.Path & "\" & Left(ThisWorkbook.Name, _
                                      Len(ThisWorkbook.Name) - 5) & ".xlsx", FileFormat:=51
.Close
End With

ErrHandler:
If Err.Number <> 0 Then
On Error GoTo 0
MsgBox "Error"
End If
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Set Newbook = Nothing
Set SourceWorkbook = Nothing
End Sub

 

[sofas]

Hi sofas. You can trial this code. HTH. Dave

Sub test()
Dim Newbook As Object, SourceWorkbook As Object
Dim cnt As Integer, PageCollect As Collection, tempworksheet As Worksheet
Set SourceWorkbook = ThisWorkbook
Set PageCollect = New Collection

On Error GoTo ErrHandler
Application.ScreenUpdating = False
Application.DisplayAlerts = False

'add sheets to collection
For Each tempworksheet In SourceWorkbook.Worksheets
If SourceWorkbook.Sheets(tempworksheet.Name).Name <> "Sheet1" Then
PageCollect.Add SourceWorkbook.Sheets(tempworksheet.Name)
End If
Next tempworksheet

'add new wb. Transfer sheets. Save to same path with same name in .xlsx format
Set Newbook = Workbooks.Add
With Newbook
For cnt = 1 To PageCollect.Count
PageCollect(cnt).Copy After:=Newbook.Sheets(Newbook.Sheets.Count)
Next cnt
.SaveAs Filename:=ThisWorkbook.Path & "\" & Left(ThisWorkbook.Name, _
                                      Len(ThisWorkbook.Name) - 5) & ".xlsx", FileFormat:=51
.Close
End With

ErrHandler:
If Err.Number <> 0 Then
On Error GoTo 0
MsgBox "Error"
End If
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Set Newbook = Nothing
Set SourceWorkbook = Nothing
End Sub

Thank you. This is what is really needed.

 

[NdNoviceHlp]

You are welcome. Thanks for posting your outcome. Dave

 

[jolivanes]

Or

Sub Save_As_Non_Macro()
Dim sh As Worksheet, shArr
For Each sh In ThisWorkbook.Worksheets
If sh.Name <> "Sheet1" Then shArr = shArr & "|" & sh.Name
Next sh
shArr = Split(Mid(shArr, 2), "|")
Sheets(shArr).Copy
    With ActiveWorkbook
            Application.DisplayAlerts = False
                .SaveAs ThisWorkbook.Path & "\" & Left(ThisWorkbook.Name, InStrRev(ThisWorkbook.Name, ".") - 1) & ".xlsx", FileFormat:=51
            Application.DisplayAlerts = True
        .Close
    End With
End Sub

 

[sofas]

Thank you all for these wonderful suggestions. I accidentally found another code that I wanted to share with you

Sub test()
    Dim Wb As Workbook, Ws As Worksheet
    Dim F As Workbook, filePath As String, Cpt()
    filePath = Application.ActiveWorkbook.Path: Set Sh = Sheets'("Sheet1")
 
    With Application
   .ScreenUpdating = False
   .DisplayAlerts = False
    
    Set Wb = ActiveWorkbook:    Set F = Workbooks.Add
    
    For Each Ws In Wb.Worksheets
    If Ws.Name <> Sh.Name Then
        n = n + 1
        ReDim Preserve Cpt(1 To n)
                 Cpt(n) = Ws.Name
        End If
    Next Ws
Wb.Sheets(Cpt).Copy After:=F.Sheets(F.Sheets.Count)
 On Error Resume Next: F.Sheets(1).Delete: On Error GoTo 0
 Application.ActiveWorkbook.SaveAs Filename:=filePath & "\" & Wb.Name & ".xlsx"
 F.Close

  .ScreenUpdating = True
  .DisplayAlerts = True
 End With
 
End Sub

 

[sofas]

Or

Sub Save_As_Non_Macro()
Dim sh As Worksheet, shArr
For Each sh In ThisWorkbook.Worksheets
If sh.Name <> "Sheet1" Then shArr = shArr & "|" & sh.Name
Next sh
shArr = Split(Mid(shArr, 2), "|")
Sheets(shArr).Copy
    With ActiveWorkbook
            Application.DisplayAlerts = False
                .SaveAs ThisWorkbook.Path & "\" & Left(ThisWorkbook.Name, InStrRev(ThisWorkbook.Name, ".") - 1) & ".xlsx", FileFormat:=51
            Application.DisplayAlerts = True
        .Close
    End With
End Sub

Or

Sub Save_As_Non_Macro()
Dim sh As Worksheet, shArr
For Each sh In ThisWorkbook.Worksheets
If sh.Name <> "Sheet1" Then shArr = shArr & "|" & sh.Name
Next sh
shArr = Split(Mid(shArr, 2), "|")
Sheets(shArr).Copy
    With ActiveWorkbook
            Application.DisplayAlerts = False
                .SaveAs ThisWorkbook.Path & "\" & Left(ThisWorkbook.Name, InStrRev(ThisWorkbook.Name, ".") - 1) & ".xlsx", FileFormat:=51
            Application.DisplayAlerts = True
        .Close
    End With
End Sub

Welcome. jolivanes

I tried your code, but unfortunately it shows an error message

 

[jolivanes]

what is the message and which line is marked?
What have you changed for the code to work on your workbook?
It works on a trial file here. Do you have a sheet named "Sheet1"

 

[sofas]

what is the message and which line is marked?
What have you changed for the code to work on your workbook?
It works on a trial file here. Do you have a sheet named "Sheet1"

really sorry. My fault: Yes, it works very well. Short and nice code.

 

[NdNoviceHlp]

@jolivanes care to share how your code works? I really don't understand what you have done there? It works great and only the sheets specified are transferred so I assume that the code modifies the existing wb and then saves it rather than creating a new wb and transferring the sheets... but I just don't see it in the code? I need some learning. Dave