New sheets based on Auto filter data

[HomePro]

I would like to take a worksheet and loop thru all possible filters in column "e"'s auto filters drop down box and copy all the data per filter to a new sheet named for that filter.
So if I had three items in the drop don list: [ball - bat - glove] I would now have 4 sheets. the original, one named bat with all the rows that had "Bat" in column e in a worksheet named BAT, another for balls etc....

Got so far and I am drawing a blank!

Sub Filter_E()
Dim Filtered As Range, ws As Worksheet
Set ws = ActiveSheet
Set Filtered = ws.AutoFilter.Range
On Error Resume Next
ws.ShowAllData
On Error GoTo 0
Filtered.AutoFilter Field:=5, Criteria1:="<>x", Operator:=xlAnd

End Sub

 

[Takae]

I may not understand exactly what you want to do, but I hope this code helps. Please note that if the same sheet name already exists in the workbook, it will stop by an error.

Sub Filter_E()
Dim ws As Worksheet, Nws As Worksheet
Dim LR As Long, LC As Long
Dim Dic, i As Long, buf As String, x

Application.ScreenUpdating = False
Set ws = Sheets("Sheet1")
Set Dic = CreateObject("Scripting.Dictionary")

    With ws
        LR = ws.Cells(Rows.Count, 1).End(xlUp).Row
        LC = ws.Cells(1, Columns.Count).End(xlToLeft).Column
        For i = 2 To LR
            buf = .Cells(i, 5).Value
            If Not Dic.Exists(buf) Then
                Dic.Add buf, buf
            End If
        Next
     
       x = Dic.Keys
     
        For i = 0 To Dic.Count - 1
            .Range("A1").AutoFilter 5, x(i)
            Worksheets.Add after:=Worksheets(Worksheets.Count)
            ActiveSheet.Name = x(i)
            Set Nws = ActiveSheet
            .Range(.Range("A1"),.Cells(LR,LC)).Copy Nws.Range("A1")
        Next
        .Range("A1").AutoFilter
        Set Dic = Nothing
    End With
    MsgBox "Done"
    Application.ScreenUpdating = False
End Sub

 

[HomePro]

Thanks, but this did not work. It gave errors right away.

 

[EXCEL MAX]

What you think about this one?

Sub FromFilterToSheets()
   
   Dim vWS As Worksheet, vA, vA2, vN As Long, vC As Long
   
   Application.ScreenUpdating = False
   Set vWS = ActiveSheet
   With vWS
      vA = .Range("E2", Cells(Rows.Count, "E").End(xlUp))
      ReDim vA2(1 To UBound(vA), 1 To 1)
      For vN = 1 To UBound(vA)
         If IsError(Application.Match(vA(vN, 1), vA2, 0)) Then
               vC = vC + 1
               vA2(vC, 1) = vA(vN, 1)
         End If
      Next vN
      For vN = 1 To vC
         .Columns("E").AutoFilter 1, vA2(vN, 1)
         Sheets.Add After:=ActiveSheet
         ActiveSheet.Name = vA2(vN, 1)
         .UsedRange.SpecialCells(xlVisible).Copy ActiveSheet.[A1]
      Next vN
      .Columns("E").AutoFilter
      .Activate
   End With
   Application.ScreenUpdating = True

End Sub

 

[HomePro]

Sorry - had to back burned this project for a bit. Will get back to you.
Thanks

 

[HomePro]

Just getting back to this. Thank you it worked great!

 

[HomePro]

If your still there. Ho9w can I adapt this to run the filter on a different column?