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

[james00]

Hi everyone.

I need some help in modifying the below VBA script:

******

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

******

The excel has 13 sheets.

Sheet 1 is used to enter some data, which then gets populated with some basic functions to the other 12 sheets which are the sheets that get split into the various excel files as per the VBA script.

I’d like the following to happen.

• Sheet 1, the data entry sheet, does not need to be saved as a separate excel file.
• I would like all other 12 sheets to be saved NOT in the same folder where the master excel is located, but within a folder of its own. This new folder needs to be created in the same folder as where the master excel is located.
• Lastly, I would like the new folder to be named on as per the data, in this case a SKU number, which the user enters into cell B2 of the sheet 1, the data entry sheet.

Your help would be greatly appreciated. THANKS!

 

[Vogateer]

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

'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

 

[james00]

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

'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

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

Just needed to make 2 small corrections, one being the "folder_name" refierence from B1 to B2 and for the second I changed "For ws_index" from 2 to 4 TO 2 to 13

 

[smozgur]

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

The marked solution has been changed accordingly. In your future questions, please mark the post as the solution that actually answered your question, instead of your feedback message as it will help future readers. No further action is required for this thread.