Hallo Henrik,

Probiere es hiermit:

Dim Lz As Long, c As Variant, FA As String, WS_liste As Worksheet, WS_neu As Worksheet, Liste As Variant, i As Integer, j As Integer, a As Range, z As Long
    
    Set WS_liste = ThisWorkbook.Sheets("Liste")
    
    ReDim Liste(i)
    
    With WS_liste
        Lz = .Cells(.Rows.Count, 4).End(xlUp).Row
        If Lz < 2 Then Exit Sub
        
        For Each a In .Range("D2:D" & Lz & "")
            If Trim(a) <> "" Then
                For j = LBound(Liste) To UBound(Liste)
                    If Liste(j) = Trim(a) Then GoTo Weiter
                Next j
                ReDim Preserve Liste(i)
                Liste(i) = Trim(a)
                i = i + 1
            End If
Weiter:
        Next a
        
        For i = LBound(Liste) To UBound(Liste)
            ThisWorkbook.Sheets.Add after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
            ActiveSheet.Name = Liste(i)
            Set WS_neu = ActiveSheet
            
            With WS_neu
                .Range("A:A").NumberFormat = "dd/mm/yyyy hh:mm:ss"
                .Range("B:B").NumberFormat = "@"
                .Range("C:D").NumberFormat = "0"
            End With
            
            z = 2
            
            With .Range("D2:D" & Lz & "")
                Set c = .Find(Liste(i), LookIn:=xlValues, lookat:=xlWhole)
                If Not c Is Nothing Then
                    FA = c.Address
                    Do
                        WS_neu.Cells(z, 1) = WS_liste.Cells(c.Row, 1) ' Spalte A
                        WS_neu.Cells(z, 2) = WS_liste.Cells(c.Row, 2).Text ' Spalte B
                        WS_neu.Cells(z, 3) = WS_liste.Cells(c.Row, 3) * 1 ' Spalte C
                        WS_neu.Cells(z, 4) = WS_liste.Cells(c.Row, 4) * 1 ' Spalte D
                        z = z + 1
                        Set c = .FindNext(c)
                    Loop While Not c Is Nothing And c.Address <> FA
                End If
            End With
            WS_neu.Cells(1, 1) = WS_liste.Cells(1, 1) ' Spalte A
            WS_neu.Cells(1, 2) = WS_liste.Cells(1, 2) ' Spalte B
            WS_neu.Cells(1, 3) = WS_liste.Cells(1, 3) ' Spalte C
            WS_neu.Cells(1, 4) = WS_liste.Cells(1, 4) ' Spalte D
            WS_neu.Range("A:D").Columns.AutoFit
            WS_neu.Range("A:D").Sort Key1:=WS_neu.Range("A1"), Order1:=xlAscending, Header:=xlGuess
        Next i
    End With