Daten nach Spaltenwert auf Blätter verteilen

Sub NachWertAufteilen()
    Dim src As Worksheet, dict As Object, c As Range, key As Variant, ziel As Worksheet, lastRow As Long
    Set src = ActiveSheet
    Set dict = CreateObject("Scripting.Dictionary")
    lastRow = src.Cells(src.Rows.Count, "A").End(xlUp).Row
    For Each c In src.Range("A2:A" & lastRow)
        If Trim(c.Value) <> "" Then dict(CStr(c.Value)) = True
    Next c
    For Each key In dict.Keys
        Set ziel = Worksheets.Add(After:=Worksheets(Worksheets.Count))
        ziel.Name = Left(Replace(CStr(key), "/", "-"), 31)
        src.Rows(1).Copy ziel.Rows(1)
        src.Range("A1").CurrentRegion.AutoFilter Field:=1, Criteria1:=key
        src.Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible).Copy ziel.Range("A1")
        src.AutoFilterMode = False
    Next key
End Sub