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
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
Bitte markiere auch die Kommentare, die zur Lösung des Beitrags beigetragen haben
Content-ID: 320225
Url: https://administrator.de/contentid/320225
Ausgedruckt am: 08.11.2024 um 07:11 Uhr
5 Kommentare
Neuester Kommentar
Servus Booster,
machst du hiermit:
Grüße Uwe
machst du hiermit:
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
Kein Problem:
Du kannst auch einautomatisches Anpassen an den Zellinhalt hiermit erreichen
Grüße Uwe
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