Split Worksheets Into Separate Workbooks

[excelbytes]

I found this code to split worksheets into separate workbooks:

Sub SplitEachWorksheet()
Dim FPath As String
FPath = Application.ActiveWorkbook.Path
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each ws In ThisWorkbook.Sheets
    ws.Copy
    Application.ActiveWorkbook.SaveAs Filename:=FPath & "\" & ws.Name & ".xlsx"
    Application.ActiveWorkbook.Close False
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

How do I modify it based on two criteria:

1) I want all the split workbooks to be saved into a different folder
2) I only want selected worksheets to be split into separate files

Thanks.

 

[DanteAmor]

Thanks for posting on the forum.

Try the following fit:

Sub SplitEachWorksheet()
  Dim FPath As String
  Dim ws As Worksheet
  
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  
  With Application.FileDialog(msoFileDialogFolderPicker)
    .Title = "Select Folder"
    If .Show <> -1 Then Exit Sub
    FPath = .SelectedItems(1)
  End With
  
  For Each ws In ThisWorkbook.Windows(1).SelectedSheets
    ws.Copy
    Application.ActiveWorkbook.SaveAs Filename:=FPath & "\" & ws.Name & ".xlsx"
    Application.ActiveWorkbook.Close False
  Next
  
  Application.DisplayAlerts = True
  Application.ScreenUpdating = True
End Sub

Let me know the result and I'll get back to you as soon as I can.
Sincerely
Dante Amor

 

[excelbytes]

DanteAmor, thanks for the quick response. I need to clarify my request a bit more. I want to hard code into the code exactly where I want the saved files to go. Also, is there a way to indicate that I only want sheet2, sheet3, sheet4, & sheet5, for example, to be saved (their actual file names would be different, see attached image)?

 

[DanteAmor]

Please try the new code.

Note: But you have to update the folder name in the code.

Sub SplitEachWorksheet()
  Dim FPath As String
  Dim sh As Worksheet
  Dim arr As Variant
  
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  
  FPath = "C:\trabajo\files"
  arr = Array("Sheet2", "Sheet3", "Sheet4", "Sheet5")
  
  For Each sh In Sheets
    If InStr(1, Join(arr, ","), sh.CodeName, vbTextCompare) > 0 Then
      sh.Copy
      Application.ActiveWorkbook.SaveAs Filename:=FPath & "\" & sh.Name & ".xlsx"
      Application.ActiveWorkbook.Close False
    End If
  Next
  
  Application.DisplayAlerts = True
  Application.ScreenUpdating = True
End Sub

Let me know the result and I'll get back to you as soon as I can.
Sincerely
Dante Amor

 

[excelbytes]

Works perfectly, thanks!

 

[excelbytes]

Dante Amor, I've run into one other snag, maybe you can help. Now that I've split the worksheets into separate workbooks, I now need to take certain workbooks and combine them as worksheets into one new workbook. I have four folders to do this with. Even though I've copied the code and just made path changes, three of the four work fine but one has a minor snag that I hope you can help me figure out. Here is the code of one that works correctly:

Sub CombineHeadcount()

Dim Path As String
Dim Filename As String
Dim Sheet As Worksheet

Application.ScreenUpdating = False

Path = "C:\Users\mremp\OneDrive\Documents\Excel Stuff\Excel Help\Edna\B 2 Gold\SheetSplit\Headcount\"
Filename = Dir(Path & "*.xlsx")

Do While Filename <> ""
Workbooks.Open Filename:=Path & Filename, ReadOnly:=True
    For Each Sheet In ActiveWorkbook.Sheets
        Sheet.Copy After:=ThisWorkbook.Sheets(1)
    Next Sheet
Workbooks(Filename).Close
Filename = Dir()
Loop

Application.ScreenUpdating = True

End Sub

Here is the code of the one that is giving me an issue:

Sub CombineTurnover()

Dim Path As String
Dim Filename As String
Dim Sheet As Worksheet

Application.ScreenUpdating = False

Path = "C:\Users\mremp\OneDrive\Documents\Excel Stuff\Excel Help\Edna\B 2 Gold\SheetSplit\Turnover\"
Filename = Dir(Path & "*.xlsx")

Do While Filename <> ""
Workbooks.Open Filename:=Path & Filename, ReadOnly:=True
    For Each Sheet In ActiveWorkbook.Sheets
        Sheet.Copy After:=ThisWorkbook.Sheets(1)
    Next Sheet
Workbooks(Filename).Close
Filename = Dir()
Loop

Application.ScreenUpdating = True

End Sub

To me they appear to be identical. Here is what's happening. On the ones that work fine, they pull in all the workbooks as worksheets into one workbook, then I can save it as a separate file. In the one that is giving me a problem, it opens each file and after it copies the file as a worksheet into the new workbook, it asks me if I want to save the changes to it. There are a total of 12 files, so I need to say Cancel after each one. Ultimately it results in combining all the files into one, but why it asks me to save the changes for each one on this one and not the other three I can't figure. Maybe it's not the code but something else I'm not seeing. Any thoughts?

 

[excelbytes]

Dante Amor, never mind, I figured it out. On the one worksheet there was a formula linking it to another worksheet, so each time those files were moved to a new workbook, it re-established the connection to another workbook and required it to be saved. Sorry to bother you on this. Thanks again for your help.