+ Reply to Thread
Results 1 to 4 of 4

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

Hybrid View

  1. #1
    Registered User
    Join Date
    12-06-2013
    Location
    Philadelphia, PA
    MS-Off Ver
    Excel 2010
    Posts
    14

    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
    Attached Files Attached Files

  2. #2
    Forum Expert Greg M's Avatar
    Join Date
    08-16-2007
    Location
    Dublin. Ireland
    MS-Off Ver
    Office 2016
    Posts
    4,641

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

    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
    Attached Files Attached Files

  3. #3
    Registered User
    Join Date
    12-06-2013
    Location
    Philadelphia, PA
    MS-Off Ver
    Excel 2010
    Posts
    14

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

    This is great! Thanks for the help Greg M!

  4. #4
    Forum Expert Greg M's Avatar
    Join Date
    08-16-2007
    Location
    Dublin. Ireland
    MS-Off Ver
    Office 2016
    Posts
    4,641

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

    Hi again,

    Many thanks for your very prompt feedback.

    You're welcome - glad I was able to help.

    Regards,

    Greg M


    P. S. Many thanks for the Reputation increase - much appreciated!
    Last edited by Greg M; 08-27-2019 at 11:42 AM. Reason: P. S. added

+ Reply to Thread

Thread Information

Users Browsing this Thread

There are currently 1 users browsing this thread. (0 members and 1 guests)

Similar Threads

  1. [SOLVED] Creating a macro to split data into separate workbooks
    By jfish07 in forum Excel Programming / VBA / Macros
    Replies: 2
    Last Post: 08-26-2019, 03:42 PM
  2. VBA to Split Worksheets into separate Workbooks by Tab Name
    By krissysteen in forum Excel Programming / VBA / Macros
    Replies: 0
    Last Post: 06-26-2019, 01:56 PM
  3. [SOLVED] Split pairs of worksheets to separate workbooks
    By vhache in forum Excel Programming / VBA / Macros
    Replies: 8
    Last Post: 08-17-2016, 05:03 PM
  4. Split Data based on 3 Columns into separate worksheets
    By angeleenmc in forum Excel Programming / VBA / Macros
    Replies: 13
    Last Post: 05-29-2014, 12:40 PM
  5. Split data into separate worksheets and sort
    By jxm1092 in forum Excel Programming / VBA / Macros
    Replies: 3
    Last Post: 11-02-2013, 05:00 AM
  6. Split my data into separate worksheets
    By drunk8gods in forum Excel Programming / VBA / Macros
    Replies: 9
    Last Post: 03-12-2010, 04:20 PM
  7. [SOLVED] Macro to Split Workbook into separate Workbooks
    By jmurray in forum Excel Programming / VBA / Macros
    Replies: 12
    Last Post: 07-14-2009, 04:44 AM

Bookmarks

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts

Search Engine Friendly URLs by vBSEO 3.6.0 RC 1