Loop to create separate filtered tabs from a master data set

[pliskers]

VBA expert, please help!
Below is some code I've used before but am having trouble adapting to new use. Basically, what I want is the following:

I have a table of sales data (named "Opp_Locator") starting in cell A9 (the header), extending to column AY, and in column N is the name of the salesperson (named "Route"). I would like to use a loop to filter the existing data and create a separate tab in the worksheet for each salesperson, with the salesperson's name from column N pasted into the name of the tab. The new salesperson tabs should ideally be pasted after the one with full details.

The data is already sorted by salesperson, so all of each person's records are sequentially grouped in order.

I was getting error messages trying to modify the code to my current layout, in part because originally the header was in row 1. Again, the table header is in row 9, but I would like the newly created tabs to include the full layout, including what's in rows 1-8.

Can anyone offer some tweaks to modify my code so it works with the data and layout as described.

Thanks a million!

JP



Option Explicit

Sub FilterData()

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 65000, "", "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

 

[DanteAmor]

I have a table of sales data (named "Opp_Locator") starting in cell A9 (the header)

So you have a table on the sheet. (Sometimes, like this, it is difficult to work with tables, but I found a solution, I hope it helps you).​

extending to column AY, and in column N is the name of the salesperson (named "Route"). I would like to use a loop to filter the existing data and create a separate tab in the worksheet for each salesperson, with the salesperson's name from column N pasted into the name of the tab...

... including what's in rows 1-8.

According to your requirement, try the following macro:​

Sub create_worksheets()
  Dim c As Range, sh As Worksheet, ky As Variant
  Dim SheetName As String
  Dim lr As Long
  Dim lobj As ListObject
  
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  
  Set sh = ActiveSheet
  Set lobj = sh.ListObjects("Opp_Locator")
  lobj.Range.AutoFilter
  
  lr = sh.Range("N" & Rows.Count).End(xlUp).Row
  
  With CreateObject("Scripting.Dictionary")
    For Each c In sh.Range("N10:N" & lr)
      .Item(c.Value) = Empty
    Next c
    
    For Each ky In .Keys
      sh.Range("A9").AutoFilter Columns("N").Column, ky
      SheetName = RTrim(Left(ky, 31))
      On Error Resume Next: Sheets(SheetName).Delete: On Error GoTo 0
      
      Sheets.Add(, Sheets(Sheets.Count)).Name = SheetName
      sh.Select
      Range("A1:AY" & lr).Copy
      Sheets(SheetName).Select
      Range("A1").Select
      ActiveSheet.Paste
    Next ky
  End With
  
  sh.Select
  sh.ShowAllData
  Application.ScreenUpdating = True
End Sub

--------------
Let me know the result and I'll get back to you as soon as I can.
Cordially
Dante Amor
--------------

 

[pliskers]

Sub create_worksheets() Dim c As Range, sh As Worksheet, ky As Variant Dim SheetName As String Dim lr As Long Dim lobj As ListObject Application.ScreenUpdating = False Application.DisplayAlerts = False Set sh = ActiveSheet Set lobj = sh.ListObjects("Opp_Locator") lobj.Range.AutoFilter lr = sh.Range("N" & Rows.Count).End(xlUp).Row With CreateObject("Scripting.Dictionary") For Each c In sh.Range("N10:N" & lr) .Item(c.Value) = Empty Next c For Each ky In .Keys sh.Range("A9").AutoFilter Columns("N").Column, ky SheetName = RTrim(Left(ky, 31)) On Error Resume Next: Sheets(SheetName).Delete: On Error GoTo 0 Sheets.Add(, Sheets(Sheets.Count)).Name = SheetName sh.Select Range("A1:AY" & lr).Copy Sheets(SheetName).Select Range("A1").Select ActiveSheet.Paste Next ky End With sh.Select sh.ShowAllData Application.ScreenUpdating = True End Sub

Thank you! The code successfully created all the required tabs, but here are the steps that are not being performed as needed:

1) All columns in the source data (columns A through AY should be pasted into each tab. Currently, the data in the tabs starts in column N (columns A-M are empty)
2) There are columns grouped in my original data, and the hidden ones were not captured and are missing from the tabs. The grouping should be disabled before doing the copy/paste.
3) The data in the source data tab is a table, with several slicers situated above the data, which starts with the header row 9. Can the data be pasted into the same rows/columns as in the original in Table format, and can the slicers be preserved on each tab? (If it's any help, there are no formulas in the table, it's all flat data.)

I may be asking for more than is possible, and I greatly appreciate your help with your original code and as many of the above modifications as you're able to make. Reach out with any further questions about what's needed.

Many thanks again!

 

[DanteAmor]

I have a table of sales data (named "Opp_Locator") starting in cell A9 (the header), extending to column AY, and in column N is the name of the salesperson (named "Route")

With that statement, I assumed the data started in cell A9.

Without a sample of your sheet, without seeing how your data is and how you want the result, it is very difficult to try to solve it.

I'm sorry but I misunderstood the requirement. I can not help you.

 

[pliskers]

That’s OK, I’ll find another way.