VBA copy data to new sheet and save with a specific cell value

[ceytl]

I have a VBA script that copies a specified sheet to a new workbook.

The problem is I want to automatically save the new workbook with the file name "1st Order" & the cell value in B5

Here is my code:

Sub SaveSplitOrder1()
    Dim NewName As String
    Dim nm As Name
    Dim ws As Worksheet

    With Application
        .ScreenUpdating = False
       

        On Error GoTo ErrCatcher
        Sheets(Array("1")).Copy
        On Error GoTo 0
       
        For Each ws In ActiveWorkbook.Worksheets
            ws.Cells.Copy
            Application.CutCopyMode = False
            Cells(1, 1).Select
            ws.Activate
        Next ws
        Cells(1, 1).Select
     
        .ScreenUpdating = True
    End With
    Exit Sub
   
ErrCatcher:
    MsgBox "Specified sheets do not exist within this workbook"
End Sub

Does anyone know how I can do that with my current code?

Thanks

 

[AlphaFrog]

Sub SaveSplitOrder1()
    
    Application.ScreenUpdating = False
    
    On Error GoTo ErrCatcher
    Sheets("1").Copy
    On Error GoTo 0
    
    ActiveWorkbook.SaveAs ThisWorkbook.Path & "\1st Order " & Range("B5").Value, FileFormat:=51
    
    Application.ScreenUpdating = True
    Exit Sub
    
ErrCatcher:
    MsgBox "Specified sheets do not exist within this workbook"
End Sub

 

[ceytl]

Sub SaveSplitOrder1()
   
    Application.ScreenUpdating = False
   
    On Error GoTo ErrCatcher
    Sheets("1").Copy
    On Error GoTo 0
   
    ActiveWorkbook.SaveAs ThisWorkbook.Path & "\1st Order " & Range("B5").Value, FileFormat:=51
   
    Application.ScreenUpdating = True
    Exit Sub
   
ErrCatcher:
    MsgBox "Specified sheets do not exist within this workbook"
End Sub

Thankyou so much!

If I wanted to save another sheet named "2" how would I loop it?

 

[AlphaFrog]

Sub SaveSplitOrder1()
    
    Dim v As Variant, ws As Worksheet
    Application.ScreenUpdating = False
    
    For Each v In Array("1", "2")
    
        Set ws = Nothing
        On Error Resume Next
        Set ws = ThisWorkbook.Sheets(v)
        On Error GoTo 0
        
        If Not ws Is Nothing Then
            ws.Copy
            ActiveWorkbook.SaveAs ThisWorkbook.Path & "\1st Order " & Range("B5").Value, FileFormat:=51
        Else
            MsgBox v & " sheet does not exist within this workbook"
        End If
    
    Next v
    
    Application.ScreenUpdating = True
End Sub

 

[ceytl]

Sub SaveSplitOrder1()
   
    Dim v As Variant, ws As Worksheet
    Application.ScreenUpdating = False
   
    For Each v In Array("1", "2")
   
        Set ws = Nothing
        On Error Resume Next
        Set ws = ThisWorkbook.Sheets(v)
        On Error GoTo 0
       
        If Not ws Is Nothing Then
            ws.Copy
            ActiveWorkbook.SaveAs ThisWorkbook.Path & "\1st Order " & Range("B5").Value, FileFormat:=51
        Else
            MsgBox v & " sheet does not exist within this workbook"
        End If
   
    Next v
   
    Application.ScreenUpdating = True
End Sub

Thank you for your help!

One last question, if I wanted sheet name "2" to save as "2nd Order" and value of B5 what would I do?

 

[AlphaFrog]

Is it just the two sheets, or would there be more?

 

[ceytl]

Is it just the two sheets, or would there be more?

Only two sheets.

 

[AlphaFrog]

Sub SaveSplitOrder1()
    
    Application.ScreenUpdating = False
    
    On Error GoTo ErrCatcher
    Sheets("1").Copy
    On Error GoTo 0
    
    ActiveWorkbook.SaveAs ThisWorkbook.Path & "\1st Order " & Range("B5").Value, FileFormat:=51
    
    On Error GoTo ErrCatcher
    Sheets("2").Copy
    On Error GoTo 0
    
    ActiveWorkbook.SaveAs ThisWorkbook.Path & "\2nd Order " & Range("B5").Value, FileFormat:=51
    
    Application.ScreenUpdating = True
    Exit Sub
    
ErrCatcher:
    MsgBox "Specified sheets do not exist within this workbook"
End Sub