Dim wb As Workbook
Dim Zelle1 As Range
Dim Zelle2 As Range
With ActiveSheet
.UsedRange.Sort key1:=.Cells(1, 1), order1:=xlAscending, Header:=xlYes
Set Zelle2 = .Cells(2, 1)
Set wb = Workbooks.Add(xlWBATWorksheet)
.Rows(1).Copy wb.Sheets(1).Cells(1, 1)
Do
Set Zelle1 = Zelle2.Offset(1, 0)
If Zelle1.Text = "" Then Exit Do
Set Zelle2 = .Columns(1).Find(what:=Zelle1.Value, lookat:=xlWhole, LookIn:=xlValues, searchdirection:=xlPrevious)
Range(Zelle1, Zelle2).Resize(, 13).Copy wb.Sheets(1).Cells(2, 1)
Application.DisplayAlerts = False
wb.SaveAs ThisWorkbook.Path & "\out\" & Zelle1.Value , FileFormat:=xlOpenXMLWorkbook
Application.DisplayAlerts = True
wb.Sheets(1).UsedRange.Offset(1, 0).Clear
Loop
wb.Close False
End With