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

james00

New Member
Joined
May 11, 2014
Messages
8
Hi everyone.

I need some help in modifying the below VBA script:

******

VBA Code:
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!
 
Last edited by a moderator:

Excel Facts

Ambidextrous Undo
Undo last command with Ctrl+Z or Alt+Backspace. If you use the Undo icon in the QAT, open the drop-down arrow to undo up to 100 steps.
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
 
Upvote 0
Solution
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
@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
 
Upvote 0
@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.
 
Upvote 0

Forum statistics

Threads
1,216,500
Messages
6,131,015
Members
449,615
Latest member
Nic0la

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top