Macro to split Large Worksheet Into Multiple Tabs

Hello to all experts:

I am trying to figure out an advanced way to split data from one tab into multiple tabs based on a certain criteria. I am attaching a sample workbook to this post for reference.

1. The criteria to split to different tabs is in Column E. I would also like the new tab to have the name of the Unique ID in Column E.
2. This list is dynamic so it could have from 5,000 to 30,000 lines.
3. Also, the criteria in Column E may not remain the same month to month. (i.e. some other ID's could be added or taken away from month to month), so I would need a way to pick up new ID's if one exists next time.

I can record the macro using filters, but I would like a shorter, less complicated macro, and I am not that far in my excel knowledge.

Thanks for all your help!

Data.xlsm

Give this a try. It took my comp about 1.5 seconds to work through it all.

Sub Extract_Uniques()
Dim ws As Worksheet:    Set ws = Sheets("Data Values")
Dim wksht As Worksheet
Dim lastrow As Long, lArray As Long
Dim arrUniques() As String
Dim bDimarr As Boolean
Dim rCell As Range

Application.ScreenUpdating = False

'establish unique values
lastrow = ws.Range("A" & Rows.Count).End(xlUp).Row
ws.Range("E1:E" & lastrow).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=ws.Range("A" & lastrow + 1), Unique:=True

'set up array of unique values
bDimarr = False

For Each rCell In ws.Range("A" & lastrow + 2, "A" & ws.Range("A" & Rows.Count).End(xlUp).Row)
    If Not IsEmpty(rCell) Then
        If bDimarr = True Then
            ReDim Preserve arrUniques(0 To UBound(arrUniques) + 1) As String
        Else
            ReDim Preserve arrUniques(0 To 0) As String
            bDimarr = True
        End If
        arrUniques(UBound(arrUniques)) = rCell.Value
    End If
Next rCell

'clear temp range
ws.Range("A" & lastrow + 1, "A" & ws.Range("A" & Rows.Count).End(xlUp).Row).ClearContents

'utilize array to perform main task
For lArray = LBound(arrUniques) To UBound(arrUniques)

    'check for existing sheet
    Set wksht = Nothing
    On Error Resume Next
    Set wksht = Sheets(arrUniques(lArray))
    If wksht Is Nothing Then
        Sheets.Add(After:=Sheets(Sheets.Count)).Name = arrUniques(lArray)
        Set wksht = Sheets(arrUniques(lArray))
    End If
    On Error GoTo 0
    
    'filter values to sheet
    With ws
        .AutoFilterMode = False
        .Range("E1:E" & .Range("E" & Rows.Count).End(xlUp).Row).AutoFilter Field:=1, Criteria1:=arrUniques(lArray)
        .AutoFilter.Range.Offset(1).EntireRow.Copy Destination:=wksht.Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
        .AutoFilterMode = False
    End With

Next lArray

Erase arrUniques
Application.ScreenUpdating = True

End Sub

This works perfectly for me with a little tweaking.

Thanks so much!