Hallo Tim,

der folgende Code sollte Dein Problem lösen:

Die Dateien werden jedes mal überschrieben:

Option Explicit

Sub DateiProWertInSpalte()
Dim SheetsArray() As String
Dim wb As Workbook, wbNeu As Workbook
Dim wsDaten As Worksheet, wsNeu As Worksheet
Dim lc As Long, lr As Long, lrNeu As Long, i As Long
Dim strKategorie As String, strPfad As String
Dim intAnzahlNeuerSheets As Integer, k As Integer

Application.DisplayAlerts = False
intAnzahlNeuerSheets = 0
Set wb = ThisWorkbook
'In diesem Beispiel sind alle Dasten im Sheet Daten gespeichert
Set wsDaten = wb.Sheets("Daten")
'Pfad der aktuellen Datei in Variabler speichern
strPfad = wb.Path

With wsDaten
    'Letzte verwendete Zeile in dem Sheet Daten ermitteln
    lr = .Cells(Rows.Count, 1).End(xlUp).Row
    'Letzte verwendete Spalte ermitteln
    lc = .Cells(1, Columns.Count).End(xlToLeft).Column
    'Alle Zeilen im Sheet Daten durchlaufen
    For i = 1 To lr
        'Spalte S -> 19
        strKategorie = .Cells(i, 19).Value
        'Prüfen, ob es ein Sheets mit dem Namen der aktuellen Kategorie gibt, falls nicht wird dies angelegt
        If Not WorksheetExists(strKategorie) Then
            'Fetslegen der letzten verwendeten Zeile im neuen Sheets
            lr = 1
            Set wsNeu = Sheets.Add(, wsDaten)
            wsNeu.Name = strKategorie
            intAnzahlNeuerSheets = intAnzahlNeuerSheets + 1
            'Namen des neuen Sheets in einem Array speichern
            ReDim Preserve SheetsArray(1 To intAnzahlNeuerSheets)
            SheetsArray(intAnzahlNeuerSheets) = ThisWorkbook.Sheets(strKategorie).Name
        End If
        Set wsNeu = Sheets(strKategorie)
        
        lrNeu = wsNeu.Cells(Rows.Count, 1).End(xlUp).Row + 1
        'Zeile in neues Sheets kopieren
        .Range(.Cells(i, 1), .Cells(i, lc)).Copy Destination:=wsNeu.Cells(lrNeu, 1)
    Next i
    
    'Für jede Kategorie wird ein neues Workbook erstellt
    For k = 1 To intAnzahlNeuerSheets
        Set wbNeu = Workbooks.Add
        strKategorie = SheetsArray(k)
        'Unter dem gleichen Pfad, wie das Original-Workbook abgespeichert
        wbNeu.SaveAs strPfad & "\" & strKategorie & ".xlsx"
        With wb.Sheets(strKategorie)
            'Die Werte aus dem jeweils neu angelegten Sheet der Kategorie wird in das Workbook kopiert
            lr = .Cells(Rows.Count, 1).End(xlUp).Row
            .Range(.Cells(1, 1), .Cells(lr, 2)).Copy wbNeu.Sheets(1).Cells(1, 1)
            'Das Workbook der jeweiligen Kategorie wird geschlossen
            wbNeu.Close SaveChanges:=True
        'Das jeweilige Sheet der Kategorie in der Hauptdatei wird gelöscht.
        wb.Sheets(strKategorie).Delete
        End With
    Next k

End With
Application.DisplayAlerts = True
End Sub

'Funktion zur Ermittlung, ob ein Worksheet bereits existiert
Function WorksheetExists(strNam As String) As Boolean
   On Error Resume Next
   WorksheetExists = Worksheets(strNam).Index > 0
End Function


Viele Grüße

Kai