Excel VBA - Für jede Zeile einer vorhandenen Datei eine neue Datei erstellen und als Dateiname Zellinhalt verwenden

Hallo zusammen,

ich stehe gerade vor folgendem Problem und hoffe auf Eure kompetente Hilfe.

Ich habe eine Excel Datei mit 410 Zeilen und 38 Spalten.

Die ersten beiden Zeilen enthalten jeweils die Überschrift/Eigenschaftsbezeichnung jeder Spalte. Die Zeilen 3-410 enthalten die Ausprägungen/Werte der Eigenschaften. Der angehängter Screenshot "Liste.xlsx" dient als Beispiel zur besseren Verständlichkeit.

Ich möchte für jede der Zeilen 3-410 eine einzelne Excel-Datei erstellen (also insgesamt 408 Dateien), die jeweils die Werte der jeweiligen Zeile und die Zeilen 1 und 2 als Benennung der Eigenschaftswerte enthalten. Der Dateiname dieser neu erzeugten Dateien, soll dem Inhalt der Spalte 2 der jeweiligen Zeile entsprechen. Für Zeile 4 des angehängten Screenshots "Liste.xlsx" sollte also beispielsweise eine Datei mit dem Dateinamen "R-LB-2" erzeugt werden (siehe Anhang).

Die Formatierung der übertragenen Zellen soll in die neue Datei übernommen werden.

Wenn möglich sollten die Zellen transponiert übertragen werden, sodass die neu erzeugte Datei 38 Zeilen und 3 Spalten enthält. Wenn das nicht möglich ist, würde ich einfach meine Quelldatei "Liste.xlsx" transponieren und die Daten dann übertragen...

Ich wäre sehr dankbar für jegliche Hilfe.


Grüße

Booster07

Sub CreateFilesFromTable()
    Dim strPath as String, cell as Range
    strPath = ActiveWorkbook.Path
    Application.ScreenUpdating = False
    With ActiveSheet
        For Each cell In .Range("A3:A" & .Cells(Rows.Count, "A").End(xlUp).Row)  
            .Range("1:2," & cell.Row & ":" & cell.Row).Copy  
            With Workbooks.Add
                .Sheets(1).Range("A1").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, Transpose:=True  
                .SaveAs strPath & "\" & cell.Offset(0, 1).Value & ".xlsx"  
                .Close
            End With
        Next
    End With
    Application.ScreenUpdating = True
    msgbox "Fertig"  
End Sub

Sub CreateFilesFromTable()
    Dim strPath As String, cell As Range
    strPath = ActiveWorkbook.Path
    Application.ScreenUpdating = False
    With ActiveSheet
        For Each cell In .Range("A3:A" & .Cells(Rows.Count, "A").End(xlUp).Row)  
            .Range("1:2," & cell.Row & ":" & cell.Row).Copy  
            With Workbooks.Add.Sheets(1)
                .Range("A1").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, Transpose:=True  
                .Range("A:B").ColumnWidth = 22.14  
                .Range("C:C").ColumnWidth = 33.57  
                .UsedRange.WrapText = True
                .SaveAs strPath & "\" & cell.Offset(0, 1).Value & ".xlsx"  
                .Close
            End With
        Next
    End With
    Application.ScreenUpdating = True
    msgbox "Fertig"  
End Sub

.UsedRange.EntireColumn.AutoFit
.UsedRange.EntireRow.AutoFit