Hallo Tim,
ich habe den Code entsprechend angepasst. Jedoch war es ein wenig widersprüchlich. Der Code kopiert in jede Datei jeweils die ersten drei Zeilen und fängt ab Zeile vier mit den Daten an. Falls dies falsch ist müsstest Du die Zeile:
.Range(.Cells(4, 1), .Cells(lr, 2)).Copy wbNeu.Sheets(1).Cells(4, 1)
'in
.Range(.Cells(3, 1), .Cells(lr, 2)).Copy wbNeu.Sheets(1).Cells(3, 1)
'ändern
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(4, Columns.Count).End(xlToLeft).Column
'Alle Zeilen im Sheet Daten durchlaufen
For i = 4 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
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)
'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 und frohe Osterfeiertage
Kai
|