Sub test()
Dim i&
Dim D As Object, Wkb As Workbook, Liste As Variant, C As Variant
Set D = CreateObject("Scripting.dictionary")
With Application
.ScreenUpdating = False
.DisplayAlerts = False
.Calculation = xlCalculationManual
End With
Sheets("ex").Copy
Set Wkb = ActiveWorkbook
With Wkb.ActiveSheet
Liste = .Range(.Cells(2, 34), .Cells(Rows.Count, 34).End(3)(2))
For i = LBound(Liste, 1) To UBound(Liste, 1)
If Liste(i, 1) <> "" Then D(Liste(i, 1)) = 0
Next i
For Each C In D.Keys
Workbooks.Add 1
.Rows(1).Copy ActiveWorkbook.ActiveSheet.Cells(1, 1)
For i = .Cells(Rows.Count, 34).End(3).Row To 2 Step -1
If .Cells(i, 34) = C Then
.Rows(i).Copy ActiveWorkbook.ActiveSheet.Cells(Rows.Count, 34).End(3)(2, -32)
.Rows(i).Delete
End If
Next i
ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & SheetName(C)
ActiveWorkbook.Close
Next C
Wkb.Close False
End With
With Application
.ScreenUpdating = True
.DisplayAlerts = True
.Calculation = xlCalculationAutomatic
End With
End Sub