Splitting a worksheet into tabs

[irksy]

HI All

I have asked this question before but can no longer find the macro that this awesome community developed for me, and now a few years down the line I need it again!

I have a worksheet comprising of 6 Columns of data. I want the data copied into separate tabs for each account manager (column F) and then the tab renaming to the account managers name.

Does that make sense?

Thanks In Advance!

 

[Fluff]

Is this the macro you're talking about
https://www.mrexcel.com/forum/excel...ata-into-separate-worksheets.html#post3519574

 

[irksy]

Thats the one! I did a search but couldnt find it.

However when i try to run it I am struggling.

I get a runtime error on line

Rng.AutoFilter Field:=18, Criteria1:=Item

 

[Fluff]

Very difficult to tell without being able to see your data, but do you have 18 or more columns of data?

 

[irksy]

so the header for my data is;

[TABLE="class: grid, width: 500"]
<tbody>[TR]
[TD]Customer[/TD]
[TD]ARR[/TD]
[TD]FY17[/TD]
[TD]#Core[/TD]
[TD]AM[/TD]
[TD]Reseller[/TD]
[TD]Footprint[/TD]
[/TR]
</tbody>[/TABLE]

With AM being the column that i want the tabs to be split by.

Currently the macro being used is;

Sub Test()    Dim Sh As Worksheet
    Dim Rng As Range
    Dim c As Range
    Dim List As New Collection
    Dim Item As Variant
    Dim WB As Workbook
    Application.ScreenUpdating = False
''   *** Change Sheet name to suit ***
    Set Sh = Worksheets("Sheet1")
    Set Rng = Sh.Range("R2:R" & Sh.Range("R" & Sh.Rows.Count).End(xlUp).Row)
    On Error Resume Next
    For Each c In Rng
        List.Add c.Value, CStr(c.Value)
    Next c
    On Error GoTo 0
    Set Rng = Sh.Range("A1:S" & Sh.Range("A" & Sh.Rows.Count).End(xlUp).Row)
    For Each Item In List
        Set WB = Workbooks.Add
        Rng.AutoFilter Field:=7, Criteria1:=Item
        Rng.SpecialCells(xlCellTypeVisible).Copy WB.Worksheets(1).Range("A1")
        Rng.AutoFilter
        With WB
            .SaveAs ThisWorkbook.Path & "\" & Item & ".xls"
            .Close
        End With
    Next Item
    Sh.Activate
    Application.ScreenUpdating = True
End Sub

But now I am getting a save as error. Dont want this to open a separate sheet just create a tab based on the AM name

 

[Fluff]

Try

Sub AddSht_FltrPaste()
' irksy (book11)

    Dim Cl As Range
    Dim UsdRws As Long
    Dim OSht As Worksheet

Application.ScreenUpdating = False

    Set OSht = Sheets("Input")
    UsdRws = OSht.Range("F" & Rows.Count).End(xlUp).Row
    OSht.Range("A1:H1").AutoFilter

    With CreateObject("scripting.dictionary")
        For Each Cl In Range("F2:F" & UsdRws)
            If Not .exists(Cl.Value) Then
                .Add Cl.Value, Nothing
                OSht.Range("A1:H" & UsdRws).AutoFilter field:=6, Criteria1:=Cl.Value
                Sheets.Add(After:=Sheets(Sheets.Count)).Name = Cl.Value
                OSht.Range("A1:H" & UsdRws).SpecialCells(xlCellTypeVisible).Copy _
                    Sheets(Cl.Text).Range("A1")
            End If
        Next Cl
    End With
    OSht.Range("A1:H1").AutoFilter

End Sub