excel vba: create worksheets based on unique values in list and copy data to applicable worksheet

[jonfull]

I have a worksheet full of data. Col A shows co_code. Each Co_code can have 1 or more rows of data. I would like to create a macro that adds and names a sheet in the same file, for each unique co_code, and then copy the applicable rows/information to the respective worksheet. Hope that makes sense.

I have code that creates a new workbook and then adds a sheet for each co_code. I dont want to create a new workbook, just add sheets within the existing workbook.
I'm trying to fix the code below, that almost does what I need it to, to create the new sheets within the current workbook and NOT in a new workbook.
Here is what I have:

Sub New_Worksheets_by_coCode()

Dim wbDest As Workbook
Dim rngFilter As Range, rngUniques As Range
Dim cell As Range, counter As Integer
Set rngFilter = Range("A1", Range("A" & Rows.Count).End(xlUp))
Application.ScreenUpdating = False
With rngFilter
.AdvancedFilter Action:=xlFilterInPlace, Unique:=True
Set rngUniques = Range("A2", Range("A" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible)
ActiveSheet.ShowAllData
End With
Application.SheetsInNewWorkbook = rngUniques.Count
Set wbDest = Workbooks.Add
Application.SheetsInNewWorkbook = 3
For Each cell In rngUniques
counter = counter + 1
rngFilter.AutoFilter Field:=1, Criteria1:=cell.Value
rngFilter.SpecialCells(xlCellTypeVisible).Copy Destination:=wbDest.Sheets(counter).Range("A1")
wbDest.Sheets(counter).Name = cell.Value

Next cell
rngFilter.Parent.AutoFilterMode = False
Application.ScreenUpdating = True

End Sub

 

[Dryver14]

Sub New_Worksheets_by_coCode()
 
'Dim wbDest As Workbook
 Dim ThisWS
 Dim rngFilter As Range, rngUniques As Range
 Dim cell As Range, counter As Integer
 Set rngFilter = Range("A1", Range("A" & Rows.Count).End(xlUp))
 Application.ScreenUpdating = False
 With rngFilter
 .AdvancedFilter Action:=xlFilterInPlace, Unique:=True
 Set rngUniques = Range("A2", Range("A" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible)
 ActiveSheet.ShowAllData
 End With
' Application.SheetsInNewWorkbook = rngUniques.Count
' Set wbDest = Workbooks.Add
' Application.SheetsInNewWorkbook = 3
 For Each cell In rngUniques
 Worksheets.Add after:=Worksheets(Worksheets.Count)
 ThisWS = cell.Value
 ActiveSheet.Name = ThisWS
 counter = counter + 1
 rngFilter.AutoFilter Field:=1, Criteria1:=cell.Value
 rngFilter.SpecialCells(xlCellTypeVisible).Copy Destination:=wbDest.Sheets(counter).Range("A1")
 Next cell
 rngFilter.Parent.AutoFilterMode = False
 Application.ScreenUpdating = True
 End Sub

 

[CA_User]

Hi - I am trying to use a variation of this code to do something extremely similar. My data table goes from columns A to P but I want do a filter on column A only. One it is filtered on A, I want to then copy the results of A to P onto a new sheet for each unique item in column A. I started with the code above but have not been able to get it to work and copy the results into each new sheet. I want the sheet name to be each unique cost center in A. I know this code was written with A as the only column so when I revised it to go from A to P, it didn't work. I am trying to do advance filter in place instead of having to copy and paste results elsewhere and then copying and pasting over. Can someone please help? Thanks in advance.

Sub NewWorksheetForEachDept()

Dim WBO As Workbook
Dim ThisWS
Dim rngFilter As Range 'filter range
Dim rngUniques As Range 'Unique Range
Dim cell As Range
Dim counter As Integer

Set WBO = ThisWorkbook
Set rngFilter = Range("A1", Range("A" & Rows.Count).End(xlUp))


With rngFilter
.AdvancedFilter Action:=xlFilterInPlace, Unique:=True
Set rngUniques = Range("A2", Range("A" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible)

ActiveSheet.ShowAllData

End With


For Each cell In rngUniques
Worksheets.Add After:=Worksheets(Worksheets.Count)
ThisWS = cell.Value
ActiveSheet.Name = ThisWS
counter = counter + 1
rngFilter.AutoFilter Field:=1, Criteria1:=cell.Value
rngFilter.SpecialCells(xlCellTypeVisible).Copy Destination:=WBO.Sheets(counter).Range("A1")

Next cell

rngFilter.Parent.AutoFilterMode = False

End Sub

 

[CA_User]

I think I just fixed my issue by revising code to this. but please feel free to let me know if there is a shorter way.

Sub NewWorksheetForEachDept()

Dim WBO As Workbook
Dim ThisWS
Dim rngFilter As Range 'filter range
Dim rngUniques As Range 'Unique Range
Dim cell As Range
Dim counter As Integer
Dim rngResults As Range 'filter range

Set WBO = ThisWorkbook
Set rngFilter = Range("A1", Range("A" & Rows.Count).End(xlUp))
Set rngResults = Range("A1", Range("P" & Rows.Count).End(xlUp))

With rngFilter
.AdvancedFilter Action:=xlFilterInPlace, Unique:=True
Set rngUniques = Range("A2", Range("A" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible)

ActiveSheet.ShowAllData

End With


For Each cell In rngUniques
Worksheets.Add After:=Worksheets(Worksheets.Count)
ThisWS = cell.Value
ActiveSheet.Name = ThisWS
'counter = counter + 1
rngFilter.AutoFilter Field:=1, Criteria1:=cell.Value
'rngFilter.SpecialCells(xlCellTypeVisible).Copy Destination:=WBO.Sheets(ThisWS).Range("A1")
rngResults.SpecialCells(xlCellTypeVisible).Copy Destination:=WBO.Sheets(ThisWS).Range("A1")

Next cell

rngFilter.Parent.AutoFilterMode = False

End Sub

 

[smilie224]

Thank you jonfull for this post. The code as-is (with the additional workbook) is exactly what I need in my variation except for one problem. I have been researching for hours with no luck.

Does anyone know how to include the extra columns with the extraction?

This example is only for Column A. I am going from Column A to AA with the data being extracted.
CA-User had an option by going to P; however, when I tried that code, it was unsuccessful for me to go to column AA instead of the P.

Everything else about this code is exactly what I need - so I would love to know if it is just something simple I am not understanding with the code.

 

[smilie224]

Since this was an utterly painful process for me to figure out (even though I knew it was some type of simple answer)... I wanted to re-post the code for anyone that might run into this problem. This code now works for me with the concept of copying Columns A through AA (substitute as needed) as an autofilter into a new workbook with all worksheets being renamed as the autofilter column code. I hope it helps someone out there save a ton of time in research!
I don't know how to do the proper indents on the forum - so my apologies for the rough looking structure here.

Sub MixedCodeAutoFilter()

Dim wbDest As Workbook
Dim rngFilter As Range, rngUniques As Range
Dim cell As Range, counter As Integer
Dim rngResults As Range 'filter range


Set rngFilter = Range("A1", Range("A" & Rows.Count).End(xlUp))
Set rngResults = Range("A1", Range("AA" & Rows.Count).End(xlUp))

Application.ScreenUpdating = False

With rngFilter
.AdvancedFilter Action:=xlFilterInPlace, Unique:=True
Set rngUniques = Range("A2", Range("A" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible)

ActiveSheet.ShowAllData

End With

Application.SheetsInNewWorkbook = rngUniques.Count
Set wbDest = Workbooks.Add
Application.SheetsInNewWorkbook = 3

For Each cell In rngUniques
counter = counter + 1
rngFilter.AutoFilter Field:=1, Criteria1:=cell.Value
rngResults.SpecialCells(xlCellTypeVisible).Copy Destination:=wbDest.Sheets(counter).Range("A1")
wbDest.Sheets(counter).Name = cell.Value


Next cell
rngFilter.Parent.AutoFilterMode = False
Application.ScreenUpdating = True

End Sub