I get a runtime error with ws.copy -> without the code works but just creates an empty workbook.

Sub SaveWorksheetAsXlsx(ws As Worksheet)
Dim filePath As String
filePath = ThisWorkbook.Path & "\" & ws.Name & ".xlsx"

' Create a new workbook
Dim newWorkbook As Workbook
Set newWorkbook = Workbooks.Add

' Copy the worksheet to the new workbook
ws.Copy 'After:=newWorkbook.Worksheets(1)

' Save the new workbook
newWorkbook.SaveAs filePath, FileFormat:=xlOpenXMLWorkbook
newWorkbook.Close SaveChanges:=False
End Sub

CodePudding user response：

set newWorkbook = workbooks.Add creates a new workbook. But ws.Copy without arguments copies ws to a new workbook. Now you have two new workbooks which is clearly not what you intend. MS learning documents gives an example of how to do copy a worksheet in its documentation on the copy command. Reference: https://learn.microsoft.com/en-us/office/vba/api/excel.worksheet.copy

Sub foo()
    Call SaveWorksheetAsXlsx(Worksheets("Sheet3"))
End Sub

Sub SaveWorksheetAsXlsx(ws As Worksheet)
Dim filePath As String

    filePath = ThisWorkbook.Path & "\" & ws.Name & ".xlsx"
    If Not CreateObject("Scripting.FileSystemObject").FileExists(filePath) Then
        ws.Copy
        ActiveWorkbook.SaveAs filePath, FileFormat:=xlOpenXMLWorkbook
        ActiveWorkbook.Close SaveChanges:=False
    Else
        MsgBox "Error: unable to save file. File already exists: "   filePath
    End If
    
 End Sub

This obviously relies on the expected behavior that when you copy a worksheet to a new workbook that workbook becomes the active workbook. I have used this before without any problems (for many years I guess), although it does make me a little nervous relying on default behaviors. So you may consider adding some guard clauses, perhaps only saving the workbook if it has an empty path (i.e., ensure it is a newly added workbook -> if ActiveWorkbook.Path = "". So, coding prophylacticly and very cautiously:

Sub foo()
    Call SaveWorksheetAsXlsx(Worksheets("Sheet3"))
End Sub

Sub SaveWorksheetAsXlsx(ws As Worksheet)
Dim filePath As String

    filePath = ThisWorkbook.Path & "\" & ws.Name & ".xlsx"
    If Not CreateObject("Scripting.FileSystemObject").FileExists(filePath) Then
        ws.Copy
        If ActiveWorkbook.Path = "" Then 'Extra check to ensure this is a newly created and unsaved workbook
            ActiveWorkbook.SaveAs filePath, FileFormat:=xlOpenXMLWorkbook
            ActiveWorkbook.Close SaveChanges:=False
        Else
            MsgBox "Unexpected error attempting to save file "   filePath
        End If
    Else
        MsgBox "Error: unable to save file. File already exists: "   filePath
    End If
    
 End Sub

CodePudding user response：

Copy Sheet to a New Workbook

• If you replace As Worksheet with As Object, the procedure will also work for charts.
• To reference the last opened workbook, you can safely use Workbook(Workbooks.Count).
• Turn off Application.DisplayAlerts to overwrite without confirmation. If you don't do this, when the file exists, you'll be asked to save it. If you select No or Cancel, the following error will occur:
  Run-time error '1004': Method 'SaveAs' of object '_Workbook' failed
• If your intent is to reference the sheet's workbook, you can use the .Parent property. Then the procedure will not be restricted just to the workbook containing this code (ThisWorkbook). Otherwise, replace Sheet.Parent with ThisWorkbook.
• If you instead of the backslash (\) use Application.PathSeparator, the procedure will also work on computers with a different operating system than Windows.
• For a new workbook, the default type is .xlsx so you don't need to specify the file extension or format.

Sub SaveSheetAsXlsx(ByVal Sheet As Object)
    ' Copy the sheet to a new single-sheet workbook.
    Sheet.Copy
    ' Reference, save and close the new workbook.
    Dim nwb As Workbook: Set nwb = Workbooks(Workbooks.Count)
    Application.DisplayAlerts = False ' overwrite without confirmation
        nwb.SaveAs Sheet.Parent.Path & Application.PathSeparator & Sheet.Name
    Application.DisplayAlerts = True
    nwb.Close False
End Sub