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
|