save individual worksheets in a workbook

[Legacy 15162]

I would like to save individual worksheets in a workbook as individual files.....this is how i was beginning to code
Public Function PDFCreate()

Dim xlApp As Excel.Application
Dim xlWB As Excel.Workbook
Dim xlWS As Excel.Worksheet
Dim stWkshtName As String

On Error GoTo pdferror

Set xlApp = GetObject(, "Excel.Application")

Set xlWB = xlApp.Workbooks.Open("\\test\testing\testfolder\periodtest\@test.xls")

For i = 1 To xlWB.Worksheets.Count()
Set xlWS = xlWB.Worksheets(i)

stWkshtName = xlWS.Name

If (Left(stWkshtName, 1)) = "0" Then
xlwb.SaveAs(

End If

next i

i would like to have the destination folder be hardcoded so that no user can change.

 

[Tazguy37]

Will this work for you?:

Sub SplitWorkbook()
    Dim ws As Worksheet
    Dim DisplayStatusBar As Boolean
    
    DisplayStatusBar = Application.DisplayStatusBar
    Application.DisplayStatusBar = True
    Application.ScreenUpdating = False
    
    For Each ws In ThisWorkbook.Sheets
        Dim NewFileName As String
        Application.StatusBar = ThisWorkbook.Sheets.Count & " Remaining Sheets"
        If ThisWorkbook.Sheets.Count <> 1 Then
        ' Instead of ThisWorkbook.Path, you can hardcode a path
            NewFileName = ThisWorkbook.Path & "\" & ws.Name & ".xls"
            ws.Copy
            ActiveWorkbook.Sheets(1).Name = "Sheet1"
            ActiveWorkbook.SaveAs Filename:=NewFileName
            ActiveWorkbook.Close savechanges:=False
        Else
            NewFileName = ThisWorkbook.Path & "\" & ws.Name & ".xls"
            ws.Name = "Sheet1"
            ThisWorkbook.SaveAs Filename:=NewFileName
        End If
    Next
    
    Application.StatusBar = False
    Application.DisplayStatusBar = DisplayStatusBar
    Application.ScreenUpdating = True
    
End Sub

Hope that helps!