VBA Split worksheet and Save to Folder based on cell value

[Edward11]

Hi, I'm trying to do the followings using VBA:
Part 1 - split my worksheet into multiple workbooks
Part 2 - save that workbook into a folder based on the cell value

An illustration of the format of file is as below:

No.	Regions	Branches	Customer Name
1	Region1	A	Ken
2	Region1	A	Ash
1	Region1	B	Dave
1	Region2	C	John
1	Region2	D	Marcus
1	Region3	E	Albert

Basically I'm splitting the worksheet based on the branches (Col C), but would like to save the new workbook (by branches) into the folder which is by regions (Col B).
I have found some code on splitting the worksheet based on cell value but was not able to get the Part 2 done.

Appreciate any input and hopefully my ending goal is understandable. -Thanks!

 

[mumps]

Change the folder path (in red) to suit your needs. Make sure that the folders in column B already exist.

Sub CreateFiles()
    Application.ScreenUpdating = False
    Dim ws As Worksheet, i As Long, arr As Variant, key As Variant
    Set ws = Sheets("Sheet1")
    arr = Range("C2", Range("C" & Rows.Count).End(xlUp)).Value
    With CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(arr, 1)
            If Not .Exists(arr(i, 1)) Then
                .Add arr(i, 1), Nothing
            End If
        Next i
        For Each key In .keys
            With ws
                .Range("A1").AutoFilter 3, key
                .AutoFilter.Range.Copy
                Workbooks.Add
                Range("A1").PasteSpecial
                Columns.AutoFit
                With ActiveWorkbook
                    .SaveAs Filename:="C:\Test\" & Range("B2") & "\" & key & ".xlsx"
                    .Close False
                End With
            End With
        Next key
        ws.Range("A1").AutoFilter
    End With
    Application.ScreenUpdating = True
End Sub

 

[Edward11]

Hi mumps, thanks for the solution. Your code seems shorter than what I’ve found from any other site.

However it works for the first time and when I try to run for the second time, it prompts a run time error ‘1004’: AutoFilter method of range class failed.

.Range("A1").AutoFilter 3, key

Also is there a way to create the folder for value in Col B if it doesn’t exist?

 

[mumps]

Are there any blank cells in column C? Could you upload a copy of your file 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 (de-sensitized if necessary).

 

[Edward11]

Hi mumps, i do have a title on 1st row and the header is on 3rd row. Data starts from 4th.

Refer to the link below for the sample file.

Master.xlsx

Shared with Dropbox

www.dropbox.com

 

[mumps]

Try:

Sub CreateFiles()
    Application.ScreenUpdating = False
    Dim ws As Worksheet, i As Long, arr As Variant, key As Variant, fObj As Object
    Set ws = Sheets("Master")
    arr = Range("C4", Range("C" & Rows.Count).End(xlUp)).Value
    With CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(arr, 1)
            If Not .Exists(arr(i, 1)) Then
                .Add arr(i, 1), Nothing
            End If
        Next i
        For Each key In .keys
            With ws
                .Range("A3").AutoFilter 3, key
                .AutoFilter.Range.Copy
                Workbooks.Add
                Range("A1").PasteSpecial
                Columns.AutoFit
                Set fObj = CreateObject("Scripting.FileSystemObject")
                If fObj.FolderExists("C:\Test\" & Range("B2")) Then
                    With ActiveWorkbook
                        .SaveAs Filename:="C:\Test\" & Range("B2") & "\" & key & ".xlsx"
                        .Close False
                    End With
                Else
                    fObj.CreateFolder ("C:\Test\" & Range("B2"))
                    With ActiveWorkbook
                        .SaveAs Filename:="C:\Test\" & Range("B2") & "\" & key & ".xlsx"
                        .Close False
                    End With
                End If
            End With
        Next key
        ws.Range("A3").AutoFilter
    End With
    Application.ScreenUpdating = True
End Sub

 

[Edward11]

Wow it works perfectly! Thanks mumps

 

[Edward11]

Hi, mumps, i tried the vba for a few times and it really works great.

But I noticed that the header row is not copied into the new workbook created.
Is it possible to include the header row (i.e. row 1:2) with the same column widths?

I also discovered that if I hide the Region column (Col B), it will instead use the Branch column (Col C) to create folder.
I do have to hide the Region column when the files are being sent.

I'm thinking to add the following code to hide the Col B, but was thinking is there any other way of doing so?

.Range("B:B").EntireColumn.Hidden = True

 

[mumps]

Try this version. Make sure that column B in the Master is not hidden. It will be hidden in the newly created files.

Sub CreateFiles()
    Application.ScreenUpdating = False
    Dim ws As Worksheet, i As Long, arr As Variant, key As Variant, fObj As Object, Fldr As String
    Set ws = Sheets("Master")
    arr = Range("C4", Range("C" & Rows.Count).End(xlUp)).Value
    With CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(arr, 1)
            If Not .Exists(arr(i, 1)) Then
                .Add arr(i, 1), Nothing
            End If
        Next i
        For Each key In .keys
            With ws
                .Range("A3").AutoFilter 3, key
                Workbooks.Add
                .Rows("1:2").Copy Range("A1")
                .AutoFilter.Range.Copy Range("A3")
                Columns.AutoFit
                Fldr = Range("B4")
                Range("B:B").EntireColumn.Hidden = True
                Set fObj = CreateObject("Scripting.FileSystemObject")
                If fObj.FolderExists("C:\Test\" & .Range("B4")) Then
                    With ActiveWorkbook
                        .SaveAs Filename:="C:\Test\" & Fldr & "\" & key & ".xlsx"
                        .Close False
                    End With
                Else
                    fObj.CreateFolder ("C:\Test\" & Fldr)
                    With ActiveWorkbook
                        .SaveAs Filename:="C:\Test\" & Fldr & "\" & key & ".xlsx"
                        .Close False
                    End With
                End If
            End With
        Next key
        ws.Range("A3").AutoFilter
    End With
    Application.ScreenUpdating = True
End Sub

 

[Edward11]

Thanks mumps! ?

Just one thing, this line get an error when I tried to run.

If fObj.FolderExists("C:\Test\" & .Range("B4")) Then

I've changed it to this and it's working fine!

If fObj.FolderExists("C:\Test\" & Fldr) Then