Moin! Das wäre der Code mit der Idee zum Löschen. Ist ungetestet, da ich nicht alles nachbauen wollte. Sollte aber eigentlich funktionieren. VG

Option Explicit
Sub KritToSheet()
Dim objShSource As Worksheet, objSh As Worksheet
Dim rng As Range, rngCopy As Range
Dim varTemp As Variant
Dim strFind As String, strFirst As String
Dim lngLast As Long, lngAct As Long
Dim rngCol As Range, intCol As Integer
Dim löschen()
Dim i As Long
 
ReDim löschen(0)

On Error Resume Next
Set rngCol = Application.InputBox("Markieren Sie eine Zelle in der" & vbLf & "gewünschten Spalte! (Kriterium)", "Tabelle aufteilen", ActiveCell.Address, Type:=8)
 
If rngCol Is Nothing Then Exit Sub
 
intCol = rngCol(1).Column
On Error GoTo ErrExit
With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .DisplayAlerts = False
    .Calculation = xlCalculationManual
    .Cursor = xlWait
End With
rngCol.Parent.Copy After:=Sheets(Sheets.Count)
Set objShSource = Sheets(Sheets.Count)
With objShSource
    lngLast = .Cells(Rows.Count, intCol).End(xlUp).Row
    lngAct = lngLast
    Do While lngAct > 1
        strFind = .Cells(2, intCol)
        Set rngCol = .Range(.Cells(2, intCol), .Cells(lngAct, intCol))
        Set rng = rngCol.Find(what:=strFind, lookat:=xlWhole)
 
        If Not rng Is Nothing Then
            strFirst = rng.Address
            Do
                If rngCopy Is Nothing Then
                    Set rngCopy = .Rows(rng.Row)
                Else
                    Set rngCopy = Union(rngCopy, .Rows(rng.Row))
                End If
                 
                Set rng = rngCol.FindNext(rng)
            Loop While Not rng Is Nothing And strFirst <> rng.Address
        End If
         
        If Not rngCopy Is Nothing Then
            Set objSh = Worksheets.Add(After:=Sheets(Sheets.Count))
            On Error Resume Next
            objSh.Name = strFind
            If Err.Number <> 0 Then
                objSh.Name = strFind & Format(Now, " hhmmss")
                Err.Clear
            End If
            
            ReDim Preserve löschen(UBound(löschen) + 1)
            löschen(UBound(löschen)) = objSh.Name
            
            On Error GoTo ErrExit
            rngCopy.Copy
            objSh.Cells(2, 1).PasteSpecial xlValues
            objSh.Cells(2, 1).PasteSpecial xlFormats
            Application.CutCopyMode = False
            objShSource.Rows(1).Copy objSh.Rows(1)
            rngCopy.Delete
            Set rngCopy = Nothing
            Set objSh = Nothing
        End If
         
        lngAct = .Cells(Rows.Count, intCol).End(xlUp).Row
    Loop
    .Delete
End With
 
'jetzt löschen
Application.DisplayAlerts = False
For i = 1 To UBound(löschen)
    Worksheets(löschen(i)).Delete
Next i
Application.DisplayAlerts = True
 
ErrExit:
Set objShSource = Nothing
Set rngCol = Nothing
With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .DisplayAlerts = True
    .Calculation = xlCalculationAutomatic
    .Cursor = xlDefault
End With
 
End Sub