将工作表复制到新工作簿中

Question

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

Answer 1

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 (ie, 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

Answer 2

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