Auto Filter, Copy to new Sheet with filter name paste results

[chris186h]

Good morning all. Hope you are all well.
I have 6 Rows with the titles A1:F1
The lenth of the list will constantly change.
What i would like to do is filter column C.
Copy all the matching results to a new sheet with the sheets name renamed to the search criteria.
I would then like it to go back and search the next filter and repeat the process untill all listed results are split onto their own sheet.

There is no set list for column C it will constantly change. I would like it to just do the action for every unique entry

I had a go with the code taken from the forum but couldnt get it to work

Sub Foo()
    Dim c As Range
    Dim rng As Range
    Dim LR As Long
        
        LR = Cells(Rows.Count, "C").End(xlUp).Row
        Set rng = Range("A1:A" & LR)
        
        Range("C1:C" & LR).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("AM1"), Unique:=True
        
        For Each c In Range([AM2], Cells(Rows.Count, "AM").End(xlUp))
            With rng
                .AutoFilter
                .AutoFilter Field:=3, Criteria1:=c.Value
                .SpecialCells(xlCellTypeVisible).Copy
                Sheets.Add(After:=Sheets(Sheets.Count)).Name = c.Value
                ActiveSheet.Paste
            End With
        Next c
        
End Sub

Thankyou for any help

 

[dmt32]

Hi,
see if this code does what you want:

Sub CreateSheets()
    Dim ws1 As Worksheet, wsAcc As Worksheet
    Dim Datarng As Range, Account As Range
    Dim rowcount As Long
    


    Set ws1 = Sheets("Sheet1")    '<< your master sheet rename as required


    Application.ScreenUpdating = False


    With ws1

        .Unprotect Password:=""  'add password if needed


        rowcount = .Cells(.Rows.Count, "A").End(xlUp).Row


        Set Datarng = .Range("A1:F" & rowcount)


        .Range("C1:C" & rowcount).AdvancedFilter _
                Action:=xlFilterCopy, _
                CopyToRange:=.Range("AM1"), _
                Unique:=True


        rowcount = .Cells(.Rows.Count, "AM").End(xlUp).Row


        'set Criteria
        .Range("AO1").Value = .Range("AM1").Value


        
        For Each Account In .Range("AM2:AM" & rowcount)
            'add the Account to criteria
            .Range("AO2").Value = Account.Value


            'Check if Account sheet exists
            On Error Resume Next
            Set wsAcc = Worksheets(Account.Value)
            On Error GoTo myerror
            
            If wsAcc Is Nothing Then
                'add account sheet
                Set wsAcc = Worksheets.Add(After:=Worksheets(Sheets.Count))
                wsAcc.Name = Account.Value
            Else
                'clear old data
                wsAcc.Cells.Clear
            End If
            
            'copy data to account sheet
            Datarng.AdvancedFilter Action:=xlFilterCopy, _
                                   CriteriaRange:=ws1.Range("AO1:AO2"), _
                                   CopyToRange:=wsAcc.Range("A1"), _
                                   Unique:=False


            wsAcc.Columns("A:F").AutoFit
            Set wsAcc = Nothing
        Next
        
        .Select
        .Columns("AM:AO").Clear
    End With
    
    Application.ScreenUpdating = True
myerror:
    If Err > 0 Then MsgBox (Error(Err)), 48, "Error"
End Sub

Change the sheet name shown in RED to match your master sheet as required.

Dave