Filter a excel column and copy paste to another new sheet and the sheet name should be filter value-CodePudding

I am applying filter to column1 and pasting the data to the new sheet I am trying to add new sheets with the filter names,eg:column 1 have a,b,c and the new sheets should be a,b,c. attaching the code I tried .can you please get me out out this problem. Thanks in advance.

Sub filter()`enter code here`
    Application.ScreenUpdating = False
    Dim x As Range
    Dim rng As Range
    Dim last As Long
    Dim sht As String

    'specify sheet name in which the data is stored
    sht = "DATA Sheet"

    'change filter column in the following code
    last = Sheets(sht).Cells(Rows.Count, "F").End(xlUp).Row
    Set rng = Sheets(sht).Range("A1:F" & last)

    Sheets(sht).Range("F1:F" & last).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("AA1"), Unique:=True

    For Each x In Range([AA2], Cells(Rows.Count, "AA").End(xlUp))
    With rng
    .AutoFilter
    .AutoFilter field:=6, Criteria1:=x.Value
    .SpecialCells(xlCellTypeVisible).Copy
    i = x
    For i = 2 To last
    Sheets.Add(after:=Sheets(Sheets.Count)).Name = Range("a" & x).Value
    'Sheets.Add.Name = Range("a3").Value
    Next i
    ActiveSheet.Paste

    End With
    Next x

    ' Turn off filter
    Sheets(sht).AutoFilterMode = False

    With Application
    .CutCopyMode = False
    .ScreenUpdating = True
    End With

End Sub

CodePudding user response：

Put the filter on Column A if that is where the names are.

Option Explicit

Sub FilterToSheet()

    Dim rng As Range, rngCopy As Range, x, arNames
    Dim last As Long, sht As String, n As Long

    'specify sheet name in which the data is stored
    sht = "DATA Sheet"

    ' filter on column A
    With Sheets(sht)
        .AutoFilterMode = False
        
        last = .Cells(Rows.Count, "A").End(xlUp).Row
        Set rng = .Range("A1:F" & last)
        .Columns("AA:AA").Clear
        .Range("A1:A" & last).AdvancedFilter Action:=xlFilterCopy, _
           CopyToRange:=.Range("AA1"), Unique:=True
        last = .Cells(Rows.Count, "AA").End(xlUp).Row
        
        ' list of filter names
        arNames = .Range("AA2:AA" & last).Value
        .Columns("AA:AA").Clear
    End With
    
    Application.ScreenUpdating = False
    
    ' aply filter for each name
    For Each x In arNames
        
        With rng
            .AutoFilter
            .AutoFilter field:=1, Criteria1:=x
            Set rngCopy = .SpecialCells(xlCellTypeVisible)
        End With
        
        Sheets.Add(after:=Sheets(Sheets.Count)).Name = x
        rngCopy.Copy
        ActiveSheet.Paste
        ActiveSheet.Range("A1").Select
        n = n   1
        
    Next x

    ' Turn off filter
    Sheets(sht).AutoFilterMode = False
    Sheets(sht).Activate

    With Application
        .CutCopyMode = False
        .ScreenUpdating = True
    End With
    MsgBox n & " sheets created", vbInformation
End Sub