Splitting worksheet into multiple based on value?

[sneeky]

Hi. I am sure this sounds more complex than it is.
I have a massive worksheet (circa 70,000) rows and each manager is responsible for a few hundred.
I want to be able to do a macro - that filters by manager and all his/her employees and duplicates the sheet, hence the sheet is split into say 50-100 sheets with each manager only having a copy of his relevant people.

However, the original sheet may change (we may add rows or columns) but there will always be a manager column which may shift here and there, so this needs to be taken into account.
I am an intermediate vba user at best so would really appreciate your guys help. As this needs to be done weekly..?

 

[Trevor G]

Wouldn't a pivot table do this for you?

 

[sneeky]

Not really. I want to click a button attached to vba code, that once you click will split out the main sheets into multiple based on the manager.. thats not really a pivot. If i was used to use some form of pivot, it would take ages to do a sheet for 100 different main managers.
Its literally splitting a sheet into duplicates but differentiated by main manager and his/her employees...

 

[sneeky]

Can anyone help with this please?

 

[Trevor G]

First a Pivot can be split into separate sheets. If you place the Managers field in the Report Filter option then when you are in the Pivot you can use the Options Tab and on the very left hand side use the Options down arrow and then select Report Filter Pages when you click OK you will get a separate sheet for each manager.

Second when you look to create the Pivot if you select loads more empty rows or Columns (if using 2007 or higher) you can just add a macro button to update the changes to all pivot tables.

Third if the Data source is placed in a Data Table that would eliminate the need to select all Columns then again a macro to update would be added.

 

[Trevor G]

If you want to go down the code line I would first get an extracted list of the managers names into a location on your worksheet. Here is the code to do that. Reason you will use this list to create the individual sheets named against each manager. So the code below creates a unique list then the next step creates individual sheets for the manager then filters the data to each sheet. You will have to change things I have highlighted in Red

Sub ExtractUniqueList()
'Using the staff worksheet
ActiveSheet.Range("G1:G1086").AdvancedFilter Action:=xlFilterCopy, _ CopyToRange:=ActiveSheet.Range("M1"), Unique:=True
'Delete M1 as it will show the title of Office
Range("M1").Delete Shift:=xlUp
End Sub

Next create the sheets from the extracted list.

Sub CreateSheetsFromAList()
Dim MyCell As Range, MyRange As Range

Set MyRange = Sheets("Staff").Range("M2")
Set MyRange = Range(MyRange, MyRange.End(xlDown))

For Each MyCell In MyRange
Sheets.Add After:=Sheets(Sheets.Count) 'creates a new worksheet
Sheets(Sheets.Count).Name = MyCell.Value ' renames the new worksheet
Next MyCell
End Sub

Then filter the data onto each worksheet

Sub filterFromSheet()
Dim i As Integer
Dim xx As String
For i = 1 To 13
On Error Resume Next
xx = Sheets("Staff").Range("M" & i).Value
Range("A1").CurrentRegion.AutoFilter field:=7, Criteria1:=xx
Range("A1").CurrentRegion.Cells.SpecialCells(xlCellTypeConstants).Copy Destination:=Sheets(xx).Range("A1")

Next
Err.Clear
Cells.AutoFilter

End Sub

 

[pliskers]

This code will prompt you to identify the field containing the values that you want to break into sheets. Make sure you've sorted your data on that field. It will name each tab for the field value it's based on:

Sub FilterDataTabs()
' Filters on a single field in a database and creates a separate filtered tab for each value in the filtered field.

Dim ws1Master As Worksheet, wsNew As Worksheet, wsFilter As Worksheet
Dim Datarng As Range, FilterRange As Range, objRange As Range
Dim rowcount As Long
Dim colcount As Integer, FilterCol As Integer
Dim SheetName As String


'master sheet
Set ws1Master = ActiveSheet
'set the Column you
'are filtering
top:
On Error Resume Next
Set objRange = Application.InputBox("Select Field Name To Filter", "Range Input", , , , , , 8)
On Error GoTo 0
If objRange Is Nothing Then
Exit Sub
ElseIf objRange.Columns.Count > 1 Then
GoTo top
End If
FilterCol = objRange.Column
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
On Error GoTo progend
'add filter sheet
Set wsFilter = Sheets.Add
With ws1Master
.Activate
.Unprotect Password:="" 'add password if needed
rowcount = .Cells(.Rows.Count, FilterCol).End(xlUp).Row
colcount = .Cells(1, .Columns.Count).End(xlToLeft).Column
If FilterCol > colcount Then
Err.Raise 650000, "", "FilterCol Setting Is Outside Data Range.", "", 0
End If
Set Datarng = .Range(.Cells(1, 1), .Cells(rowcount, colcount))
'extract Unique values from FilterCol
.Range(.Cells(1, FilterCol), _
.Cells(rowcount, _
FilterCol)).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=wsFilter.Range("A1"), _
Unique:=True
rowcount = wsFilter.Cells(wsFilter.Rows.Count, "A").End(xlUp).Row
'set Criteria
wsFilter.Range("B1").Value = wsFilter.Range("A1").Value
For Each FilterRange In wsFilter.Range("A2:A" & rowcount)
'check for blank cell in range
If Len(FilterRange.Value) > 0 Then
'add the FilterRange to criteria
wsFilter.Range("B2").Value = FilterRange.Value
SheetName = RTrim(Left(FilterRange.Value, 31))
'if FilterRange sheet exists
'update it
If SheetExists(SheetName) Then
Sheets(SheetName).Cells.Clear
Else
'add new sheet
Set wsNew = Sheets.Add
wsNew.Move After:=Worksheets(Worksheets.Count)
wsNew.Name = SheetName
End If
Datarng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=wsFilter.Range("B1:B2"), _
CopyToRange:=Sheets(SheetName).Range("A1"), _
Unique:=False
End If
Next
.Select
End With
progend:
wsFilter.Delete
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
If Err > 0 Then
MsgBox (Error(Err)), vbCritical, "Error"
Err.Clear
End If
End Sub