Use VBA Macro to Save each Excel Worksheet as Sepa

Question

Hi I am trying to use this code to save each sheet of Excel to a new workbook. However, it is saving the entire workbook to the new filename

Dim path As String
Dim dt As String
dt = Now()
path = CreateObject("WScript.Shell").specialfolders("Desktop") & "\Calendars " & Replace(Replace(dt, ":", "."), "/", ".")
MkDir path
Call Shell("explorer.exe" & " " & path, vbNormalFocus)

Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets 'SetVersions
    If ws.name <> "How-To" And ws.name <> "Actg_Prd" Then
        ws.SaveAs path & ws.name, xlsx
    End If
Next ws

What is the quick fix?

Answer 1

Keeping the worksheet in the existing workbook and creating a new workbook with a copy

Dim path As String
Dim dt As String
dt = Now()
path = CreateObject("WScript.Shell").specialfolders("Desktop") & "\Calendars " & Replace(Replace(dt, ":", "."), "/", ".")
MkDir path
Call Shell("explorer.exe" & " " & path, vbNormalFocus)

Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets 'SetVersions
    If ws.Name <> "How-To" And ws.Name <> "Actg_Prd" Then
        Dim wb As Workbook
        Set wb = ws.Application.Workbooks.Add
        ws.Copy Before:=wb.Sheets(1)
        wb.SaveAs path & ws.Name, Excel.XlFileFormat.xlOpenXMLWorkbook
        Set wb = Nothing
    End If
Next ws

Answer 2

I recommend introducing some error checking so as to ensure the folder you'll ultimately try to save workbooks to, actually exists. This will also create the folder relative to wherever you've saved your macro-enabled excel file.

On Error Resume Next
MkDir ThisWorkbook.path & "\Calendars\"
On Error GoTo 0

I also highly recommend closing the newly created workbook as soon as it's saved. If you are trying to create a large number of new workbooks, you'll quickly find how much it lags your system.

wb.Close

Moreover, Sorceri's code will not save an excel file with the appropriate file extension. You must specify that in the file name.

Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets 'SetVersions
    If ws.Name <> "How-To" And ws.Name <> "Actg_Prd" Then
        Dim wb As Workbook
        Set wb = ws.Application.Workbooks.Add
        ws.Copy Before:=wb.Sheets(1)
        wb.SaveAs path & ws.Name & ".xlsx", Excel.XlFileFormat.xlOpenXMLWorkbook
        wb.Close
        Set wb = Nothing
    End If
Next ws