Sub Schaltfläche1_Klicken()
Dim loLetzte As Long, loSpalte As Long, i As Long
Dim strBlattname As String
Application.ScreenUpdating = False
With ActiveSheet
loLetzte = .Cells(.Rows.Count, "A").End(xlUp).Row
loSpalte = .Cells(1, .Columns.Count).End(xlToLeft).Offset(, 2).Column
.Range(.Cells(1, "A"), .Cells(loLetzte, "A")).Copy .Cells(1, loSpalte)
.Columns(loSpalte).RemoveDuplicates Columns:=1, Header:=xlYes
For i = 2 To .Cells(.Rows.Count, loSpalte).End(xlUp).Row
strBlattname = .Cells(i, loSpalte)
.Range("A1").CurrentRegion.AutoFilter field:=1, Criteria1:=.Cells(i, loSpalte)
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = strBlattname
With .AutoFilter.Range
.Copy
Worksheets(strBlattname).Range("A1").PasteSpecial Paste:=xlPasteAll
End With
Next i
.Columns(loSpalte).Delete
.AutoFilterMode = False
.Activate
End With
End Sub