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.

 

[james00]

Hi all.

Trying to figure out how to add some VBA code to save the split excel sheets into DATA ONLY sheets?
Right now it saves each sheet with all my functions and formulas, so many cells, although blank if criteria are not met, still have the functions/formulas in them. I', like these to be saved BLANK, ie nothing in the cells which do not meet the criteria.

Any ideas would be greatly appreciated

 

[mumps]

Try:

Sub SplitEachWorksheet()
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
    End With
    Dim FPath As String, ws_index As Long, ws_name As String
    Dim folder_name As String, new_workbook As Workbook, rng As Range
    FPath = ThisWorkbook.path
    folder_name = ThisWorkbook.Sheets(1).Range("B2").Value2
    Application.DisplayAlerts = False
    Call make_dir(folder_name, FPath)
    For ws_index = 2 To 13
        ws_name = ThisWorkbook.Sheets(ws_index).Name
        ThisWorkbook.Worksheets(ws_index).Copy
        Set new_workbook = ActiveWorkbook
        With new_workbook
            For Each rng In .Sheets(1).UsedRange
                If Len(rng) = 0 Then
                    rng.Value = rng.Value
                End If
            Next rng
            .SaveAs Filename:=FPath & "\" & folder_name & "\" & ws_name & ".xlsx"
            .Close False
        End With
    Next ws_index
    Set new_workbook = Nothing
    With Application
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With
End Sub

 

[mumps]

I'd like these cells that should not return data if criteria are not met to be saved BLANK, ie nothing in those cells*

This would mean that the cells that have formulae but return a blank cell would have the formulae removed. Is this correct?
It would be easier to help if you could use the XL2BB add-in (icon in the menu) to attach a screenshot (not a picture) of your sheet. Alternately, you could upload a copy of your file(de-sensitized if necessary) to a free site such as www.box.com or www.dropbox.com. Once you do that, mark it for 'Sharing' and you will be given a link to the file that you can post here.

 

[james00]

oops, solved it I think.