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
Bookmarks