Creating a macro to split data into separate workbooks and separate worksheets

Hi - I have a data file that contains the following columns: Name, Region Name, Territory Name, Address, City, State, Zip

I would like to create a macro that would break this data down into separate workbooks by region. There are 9 different regions. I would also like these 9 individual region files to split into multiple worksheets based on the amount of territories per region (i.e. the west region has 10 territories, so it would have 10 separate worksheets of data for the west region file).

Attached is the file i have created so far. I have created the macro to split the files into regions and save them to a specific path on my desktop, however, i need the next step of breaking them into multiple worksheets per region file.

I am looking to continue the code already written, however, I am open to any new code if its easier for the process. Any help would be appreciated! Thanks!

Below is the code i have so far which is in the attached file.


Sub Split_Data_in_workbooks()

Application.ScreenUpdating = False

Dim data_sh As Worksheet
Set data_sh = ThisWorkbook.Sheets("Data")

Dim setting_Sh As Worksheet
Set setting_Sh = ThisWorkbook.Sheets("Settings")

Dim nwb As Workbook
Dim nsh As Worksheet

''''' Get unique Region

setting_Sh.Range("A:A").Clear
data_sh.AutoFilterMode = False
data_sh.Range("B:B").Copy setting_Sh.Range("A1")

setting_Sh.Range("A:A").RemoveDuplicates 1, xlYes

Dim i As Integer

For i = 2 To Application.CountA(setting_Sh.Range("A:A"))

data_sh.UsedRange.AutoFilter 2, setting_Sh.Range("A" & i).Value


Set nwb = Workbooks.Add
Set nsh = nwb.Sheets(1)

data_sh.UsedRange.SpecialCells(xlCellTypeVisible).Copy nsh.Range("A1")
nsh.UsedRange.EntireColumn.ColumnWidth = 15

nwb.SaveAs setting_Sh.Range("H6").Value & "/" & setting_Sh.Range("A" & i).Value & ".xlsx"
nwb.Close False
data_sh.AutoFilterMode = False
Next i

setting_Sh.Range("A:A").Clear

MsgBox "Done"

End Sub

Hi there,

See if the attached version of your workbook does what you need. It uses the following code:

Option Explicit


'=========================================================================================
'=========================================================================================
    
    
Const miHEADER_ROW_NO   As Integer = 1
Const miCOLUMN_WIDTH    As Integer = 15


'=========================================================================================
'=========================================================================================


Sub SeparateData()

    Const sCOLUMN_REGION    As String = "B"
    Const sDATA_SHEET       As String = "DATA"

    Dim rRangeToFilter      As Range
    Dim sRegionName         As String
    Dim colRegions          As Collection
    Dim iRegionNo           As Integer
    Dim wksData             As Worksheet

    Set wksData = ThisWorkbook.Worksheets(sDATA_SHEET)

    Application.ScreenUpdating = False

'   Before starting, ensure that no previously-existing filter has been applied
    wksData.AutoFilterMode = False

    Set rRangeToFilter = mrRangeToFilter(wksData:=wksData)

'   Retrieve a collection containing all of the Region names
    Set colRegions = mcolFilterCriteria(rRangeToFilter:=rRangeToFilter, _
                                        sCriteriaColumn:=sCOLUMN_REGION)

'   Scan through each of the Region names
    For iRegionNo = 1 To colRegions.Count

'       Determine the current Region name
        sRegionName = colRegions(iRegionNo)

'       Create a new workbook to contain the data for the current Region name
        Call CreateNewWorkbook(rRangeToFilter:=rRangeToFilter, _
                               sCriteriaColumn:=sCOLUMN_REGION, _
                               sRegionName:=sRegionName)

    Next iRegionNo

    Application.ScreenUpdating = True

    MsgBox colRegions.Count & " workbooks created", _
           vbInformation, "Operation completed"

End Sub


'=========================================================================================
'=========================================================================================


Sub CreateNewWorkbook(rRangeToFilter As Range, _
                      sCriteriaColumn As String, sRegionName As String)

    Const sEXTENSION    As String = ".xlsx"

    Dim wksRegion       As Worksheet
    Dim wbkRegion       As Workbook
    Dim sFullName       As String
    Dim iFieldNo        As Integer

    sFullName = ThisWorkbook.Path & "\" & sRegionName & sEXTENSION

    Application.StatusBar = "Creating workbook for region: " & sRegionName

        With rRangeToFilter

            iFieldNo = .Columns(sCriteriaColumn).Column

            .AutoFilter Field:=iFieldNo, Criteria1:=sRegionName

            Set wbkRegion = Workbooks.Add
            Set wksRegion = ActiveSheet

            With rRangeToFilter.SpecialCells(xlCellTypeVisible)
                .Copy Destination:=wksRegion.Cells(1, 1)
            End With

            wksRegion.UsedRange.EntireColumn.ColumnWidth = miCOLUMN_WIDTH

            Call CreateNewWorksheets(wbkRegion:=wbkRegion)

            wbkRegion.SaveAs Filename:=sFullName
            wbkRegion.Close SaveChanges:=False

            .Parent.AutoFilterMode = False

        End With

    Application.StatusBar = False

End Sub


'=========================================================================================
'=========================================================================================


Sub CreateNewWorksheets(wbkRegion As Workbook)

    Const sCOLUMN_TERRITORY As String = "C"

    Dim rRangeToFilter      As Range
    Dim colTerritories      As Collection
    Dim wksTerritory        As Worksheet
    Dim iTerritoryNo        As Integer
    Dim wksData             As Worksheet

    Set wksData = wbkRegion.Worksheets(1)

'   Determine the range to be filtered in the newly-created (Region) workbook
    Set rRangeToFilter = mrRangeToFilter(wksData:=wksData)

'   Retrieve a collection containing all of the Territory names
'   associated with the current Region name
    Set colTerritories = mcolFilterCriteria(rRangeToFilter:=rRangeToFilter, _
                                            sCriteriaColumn:=sCOLUMN_TERRITORY)

'   Scan through each of the above Territory names
    For iTerritoryNo = 1 To colTerritories.Count

        With rRangeToFilter

'           Apply the Territory filter to the main worksheet in the new workbook
            .AutoFilter Field:=(.Columns(sCOLUMN_TERRITORY).Column), _
                                Criteria1:=colTerritories(iTerritoryNo)

'           Add a new worksheet to the new workbook to contain all
'           of the the data for the current Territory name
            With wbkRegion
                Set wksTerritory = .Worksheets.Add(After:=Worksheets(.Worksheets.Count))
            End With

'           Copy the filtered (Region and Territory) data to the new worksheet
            With rRangeToFilter.SpecialCells(xlCellTypeVisible)
                .Copy Destination:=wksTerritory.Cells(1, 1)
            End With

'           Set the column widths on the new worksheet
            wksTerritory.UsedRange.EntireColumn.ColumnWidth = miCOLUMN_WIDTH

'           Rename the new worksheet as the current Territory name
            wksTerritory.Name = colTerritories(iTerritoryNo)

'           Remove any filtering from the main worksheet in the new workbook
            .Parent.AutoFilterMode = False

        End With

    Next iTerritoryNo

'   Delete the main worksheet (which contains data for ALL Territory names)
    Application.DisplayAlerts = False
        wksData.Delete
    Application.DisplayAlerts = True

'   Select the first worksheet in the new workbook
    wbkRegion.Worksheets(1).Activate

End Sub


'=========================================================================================
'=========================================================================================


Private Function mrRangeToFilter(wksData As Worksheet) As Range

    With wksData

        Set mrRangeToFilter = Range(.Cells(miHEADER_ROW_NO, 1), _
                                    .UsedRange.Cells(.UsedRange.Cells.Count))

    End With

End Function


'=========================================================================================
'=========================================================================================


Private Function mcolFilterCriteria(rRangeToFilter As Range, _
                                    sCriteriaColumn As String) As Collection

    Dim colFilterCriteria   As Collection
    Dim rCriteria           As Range
    Dim wksData             As Worksheet
    Dim vValue              As Variant
    Dim rCell               As Range

    Set colFilterCriteria = New Collection
    Set wksData = rRangeToFilter.Parent

    Set rCriteria = Intersect(rRangeToFilter, _
                              wksData.Columns(sCriteriaColumn))

'   Ignore the Header row in the above range
    With rCriteria
        Set rCriteria = Range(.Rows(2), _
                              .Rows(.Rows.Count))
    End With

    For Each rCell In rCriteria.Cells

'       This routine creates a list of the unique values shown in the Criteria
'       column, but attempting to add non-unique keys to a Collection will
'       create an error condition - ignoring the error ensures that only
'       unique key values are added to the Collection
        On Error Resume Next
            vValue = rCell.Value
            colFilterCriteria.Add vValue, CStr(vValue)
        On Error GoTo 0

    Next rCell

    Set mcolFilterCriteria = colFilterCriteria

End Function

The highlighted values may be altered to suit your requirements.


The "child" workbooks are created in the same folder as the main workbook. If you are happy with this, the "Settings" worksheet is no longer required.


Hope this helps - please let me know how you get on.

Regards,

Greg M

This is great! Thanks for the help Greg M!