VBA script - split sheets into unique folder named of cell entry

Vogateer said:

This might do it. As mentioned, you'll need to add the reference to the Microsoft Scripting Runtime before the make_dir will work.

VBA Code:

'Add reference to Microsoft Scripting Runtime with Tools -> References
Sub make_dir(dir_name As String, dir_path As String)

    Dim fso As New FileSystemObject
    Dim path As String
   
    path = dir_path & "\" & dir_name
   
    If Not fso.FolderExists(path) Then
        ' doesn't exist, so create the folder
        fso.CreateFolder path
    End If

End Sub


Sub SplitEachWorksheet()
    Dim FPath As String, ws_index As Long, ws_name As String
    Dim folder_name As String, new_workbook As Workbook
   
    FPath = ThisWorkbook.path
    folder_name = ThisWorkbook.Sheets(1).Range("B1").Value2
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
   
    Call make_dir(folder_name, FPath)
    For ws_index = 2 To 4
        ws_name = ThisWorkbook.Sheets(ws_index).Name
        ThisWorkbook.Worksheets(ws_index).Copy
        Set new_workbook = ActiveWorkbook
        new_workbook.SaveAs Filename:=FPath & "\" & folder_name & "\" & _
            ws_name & ".xlsx"
        new_workbook.Close False
        Next ws_index
   
    Set new_workbook = Nothing
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
   
End Sub

Click to expand...

james00 said:

@Vogateer - this worked perfectly, thanks so much for helping me out.

Click to expand...