Splitting Filtered Data

[Masterz13]

Hi,

My First post! (Of Many)

Basically I have a massive set of Data. This shows about 800 eomployees and also has what team each employee is in.
I want the whole workbook to be automatically split apart into seperate or tabs, or ideally, seperate worksheets all together. Is this possible?
All im aware of at the moment is manually filtering them on team, and them copying an pasting them into their own tabs/worksheets.

Please let me know if there is a clever way around this!

Cheers

 

[apo]

Hi..

I found some excellent code that should do just what you want.

It was written by a guy called Ger Plante.. so all credit to him.

The code below looks in Column A.. just change that to the column where your "Team" values are.

I am pretty sure that, as per the Rules on this forum.. I can't post a link to it.. but at least credit has been given to the rightful person..

Public Sub Unique_Record_Extract()


'extracts unique records from Column A and copies those records to a new workshee


Dim My_Range As Range
Dim My_Cell As Variant
Dim sh_Original As Worksheet


'turn off interactive stuff to speed it up
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False




'add a new worksheet to temporarily store unique record names
Set sh_Original = ActiveSheet


On Error Resume Next
Sheets("TEMPXXX").Delete
On Error GoTo 0
Worksheets.Add
ActiveSheet.Name = "TEMPXXX"


'copy all unique records from main sheet into temporary sheet
Worksheets("Sheet1").Columns("A:A").AdvancedFilter Action:=xlFilterCopy, _
        CopyToRange:=Columns("A:A"), Unique:=True


'set up list of unique records stored on the temporary sheet
'start in cell A2 because the advanced filter will copy headers too.
Set My_Range = Range("A2:A" & Range("A65536").End(xlUp).Row)


'cycle through each unique entry in the list and filter the original sheet with that value
For Each My_Cell In My_Range
    'create a new worksheet with unique record name (delete it first if it aleady exists)
    On Error Resume Next
    Sheets(My_Cell.Value).Delete 'delete if already exists
    On Error GoTo 0
    Worksheets.Add 'add new sheet which subsequently becomes the active sheet
    ActiveSheet.Name = My_Cell.Value ' be careful here of worksheet names > 31 characters
           
    'filter Original sheet
     sh_Original.UsedRange.AutoFilter Field:=1, Criteria1:=My_Cell.Value
     
    'copied filter list to the activesheet (which is the sheet just recently added)
    sh_Original.Cells.SpecialCells(xlVisible).Copy Destination:=Range("A1")
    
    'autofit the columns to make it look pretty
    Columns.AutoFit
    
    'you could delete column A in the target worksheet since it contains all the same unique record name
    'and the unique record is listed in the worksheet tab name anyway! If so
    'un comment the following line.
    'Columns("A:A").Delete
    
    'you could insert code here to copy or move the new worksheet to a new workbook and save it
    
    
Next


'tidy up!
Worksheets("TEMPXXX").Delete
sh_Original.AutoFilterMode = False
Set sh_Original = Nothing


Application.DisplayAlerts = True
Application.Calculation = xlAutomatic
Application.ScreenUpdating = True


End Sub

 

[Rambo4711]

Amazing !!!