Save Multiple Files to One Location with Dialogue Box

[jordancollins]

Hello, I am trying to save multiple worksheets within one file to the same file location without having to pick the folder for every file that is being saved. The file that I am currently working in has 20 sheets that get saved. I am sure that I am missing something silly...

Sub SplitEachWorksheet()
Dim FilePath As String
Dim Fldr As String
FPath = Application.ActiveWorkbook.Path
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each ws In ThisWorkbook.Sheets
If Not ws.Name Like "Summary" Then
ws.Copy
With Application.FileDialog(4)
.AllowMultiSelect = False
If .Show <> -1 Then Exit Sub
Fldr = .SelectedItems(1)
End With
ActiveWorkbook.SaveAs Fldr & "\" & ws.Name & ".xlsx"
Application.ActiveWorkbook.Close False
Else
End If
Next ws
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

 

[HighAndWilder]

Are you expecting to have an additional 20 workbooks, each having one worksheet from the source workbook?

 

[John_w]

Move the Application.FileDialog(4) above the loop, like this:

Public Sub Save_Each_Sheet_As_Workbook()

    Dim folder As Variant
    Dim ws As Worksheet
    
    With Application.FileDialog(msoFileDialogFolderPicker)
        .AllowMultiSelect = False
        .Title = "Select destination folder"
        If Not .Show Then Exit Sub
        folder = .SelectedItems(1) & "\"
    End With
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False  'suppress warning if .xlsx file already exists - file is replaced
    
    With ThisWorkbook
        For Each ws In .Worksheets
            If StrComp(ws.Name, "Summary", vbTextCompare) <> 0 Then
                ws.Copy
                ActiveWorkbook.SaveAs folder & ws.Name & ".xlsx"
                ActiveWorkbook.Close SaveChanges:=False
            End If
        Next
    End With
    
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    
    MsgBox "Done"
    
End Sub

 

[jordancollins]

Are you expecting to have an additional 20 workbooks, each having one worksheet from the source workbook?

Yes, that is the idea. I am creating individual excel reports for 20 different people.

 

[jordancollins]

Move the Application.FileDialog(4) above the loop, like this:

Public Sub Save_Each_Sheet_As_Workbook()

    Dim folder As Variant
    Dim ws As Worksheet
   
    With Application.FileDialog(msoFileDialogFolderPicker)
        .AllowMultiSelect = False
        .Title = "Select destination folder"
        If Not .Show Then Exit Sub
        folder = .SelectedItems(1) & "\"
    End With
   
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False  'suppress warning if .xlsx file already exists - file is replaced
   
    With ThisWorkbook
        For Each ws In .Worksheets
            If StrComp(ws.Name, "Summary", vbTextCompare) <> 0 Then
                ws.Copy
                ActiveWorkbook.SaveAs folder & ws.Name & ".xlsx"
                ActiveWorkbook.Close SaveChanges:=False
            End If
        Next
    End With
   
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
   
    MsgBox "Done"
   
End Sub

@John_w that worked, thank you very much!