Sub speicher()
    On Error GoTo Fehler
    
    Dim wkb As Workbook, wkbNeu As Workbook, wks As Worksheet, wksTmp As Worksheet, wksNeu As Worksheet
    Dim i As Integer, LR As Integer
    Dim Arr()
    Dim Pfad As String, Dateiname As String
    
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
    End With
    
    Set wkb = ThisWorkbook
    
    Set wks = wkb.ActiveSheet
    Pfad = wks.Range("I4")
    Dateiname = wks.Range("I23")
    
    If wks.AutoFilterMode Then wks.AutoFilterMode = False ' Autofilter ausschalten
    
    Set wksTmp = wkb.Sheets.Add(after:=wkb.Sheets(wkb.Sheets.Count))
    
    With wksTmp
        'kopieren und Duplikate raus
        wks.Columns(4).Copy .Columns(1)
        .Columns(1).RemoveDuplicates Columns:=1, Header:=xlYes
        
        LR = .Cells(.Rows.Count, 1).End(xlUp).Row 'letzte Zeile der Spalte 1
    
        Arr = .Range(.Cells(2, 1), .Cells(LR, 1))
    End With
    
    'Neues Blatt erstellen und gefilterte Daten kopieren
    Set wkbNeu = Workbooks.Add
    For i = LBound(Arr) To UBound(Arr)
        Set wksNeu = wkb.Sheets.Add(after:=wkb.Sheets(wkb.Sheets.Count))
        wks.Columns(4).AutoFilter Field:=1, Criteria1:=Arr(i, 1)
        wks.Columns(1).Resize(, 3).Copy wksNeu.Columns(1).Resize(, 3)
        wksNeu.Name = Arr(i, 1)
             
        'Blatt in neue Datei verschieben
        wksNeu.Move after:=wkbNeu.Sheets(wkbNeu.Sheets.Count)
    Next
    
    'Filter ausschalten
    wks.AutoFilterMode = False
    
    'temporäres Blatt löschen
    Application.DisplayAlerts = False
    wksTmp.Delete
    
    'Neue Datei speichern und schließen
    wkbNeu.SaveAs Filename:=Pfad & "\" & Dateiname & ".xlsx", _
        FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    wkbNeu.Close

    '*** Fehlerbehandlung
    Err.Clear
    
Fehler:
    '*** Rücksetzen
    With Application
        .DisplayAlerts = True
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
    End With
    If Err.Number <> 0 Then MsgBox "Fehler: " & _
        Err.Number & vbLf & Err.Description: Err.Clear
End Sub