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)
WS_neu.Cells(z, 2) = WS_liste.Cells(c.Row, 2).Text
WS_neu.Cells(z, 3) = WS_liste.Cells(c.Row, 3) * 1
WS_neu.Cells(z, 4) = WS_liste.Cells(c.Row, 4) * 1
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)
WS_neu.Cells(1, 2) = WS_liste.Cells(1, 2)
WS_neu.Cells(1, 3) = WS_liste.Cells(1, 3)
WS_neu.Cells(1, 4) = WS_liste.Cells(1, 4)
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