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
Set wsDaten = wb.Sheets("Daten")
strPfad = wb.Path
With wsDaten
lr = .Cells(Rows.Count, 1).End(xlUp).Row
lc = .Cells(4, Columns.Count).End(xlToLeft).Column
For i = 4 To lr
strKategorie = .Cells(i, 19).Value
If Not WorksheetExists(strKategorie) Then
lr = 1
Set wsNeu = Sheets.Add(, wsDaten)
wsNeu.Name = strKategorie
intAnzahlNeuerSheets = intAnzahlNeuerSheets + 1
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
.Range(.Cells(i, 1), .Cells(i, lc)).Copy Destination:=wsNeu.Cells(lrNeu, 1)
Next i
For k = 1 To intAnzahlNeuerSheets
Set wbNeu = Workbooks.Add
strKategorie = SheetsArray(k)
wbNeu.SaveAs strPfad & "\" & strKategorie & ".xlsx"
With wb.Sheets(strKategorie)
lr = .Cells(Rows.Count, 1).End(xlUp).Row
wsDaten.Range(wsDaten.Cells(1, 1), wsDaten.Cells(3, 2)).Copy wbNeu.Sheets(1).Cells(1, 1)
.Range(.Cells(4, 1), .Cells(lr, 2)).Copy wbNeu.Sheets(1).Cells(4, 1)
wbNeu.Close SaveChanges:=True
wb.Sheets(strKategorie).Delete
End With
Next k
End With
Application.DisplayAlerts = True
End Sub
Function WorksheetExists(strNam As String) As Boolean
On Error Resume Next
WorksheetExists = Worksheets(strNam).Index > 0
End Function