booster07
Goto Top

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
liste.xlsx
r-lb-2.xlsx

Content-ID: 320225

Url: https://administrator.de/contentid/320225

Ausgedruckt am: 25.11.2024 um 15:11 Uhr

colinardo
Lösung colinardo 07.11.2016 aktualisiert um 14:17:57 Uhr
Goto Top
Servus Booster,
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
Grüße Uwe
Booster07
Booster07 07.11.2016 um 14:11:33 Uhr
Goto Top
Servus Uwe,

super funktioniert einwandfrei!

Vielen vielen Dank!

Grüße
Booster07
Booster07 07.11.2016 um 14:34:39 Uhr
Goto Top
Servus Uwe,

Entschuldigung, ich habe doch noch eine Frage. Vielleicht kannst Du mir ein weiteres Mal helfen?

Wie kann ich jetzt in den erzeugten Dateien eine definierte Spaltenbreite, einen automatischen Zeilenumbruch und eine optimierte Zeilenhöhe erreichen? Ich habe versucht in Zeile 9, die Befehle "WrapText:=True", "ColumnWidth:=220" und Rows.AutoFit einzubringen. Klappt aber leider nicht...

Optimal wäre eine Spaltenbreite der Spalten A und B von 160 und der Spalte C von 240. Wenn es viel einfacher ist, wäre aber auch eine Spaltenbreite aller drei Spalten von 220 ok.

Grüße Booster
colinardo
Lösung colinardo 07.11.2016 aktualisiert um 15:21:33 Uhr
Goto Top
Kein Problem:
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
Du kannst auch einautomatisches Anpassen an den Zellinhalt hiermit erreichen
.UsedRange.EntireColumn.AutoFit
.UsedRange.EntireRow.AutoFit
Grüße Uwe
Booster07
Booster07 07.11.2016 um 15:37:58 Uhr
Goto Top
Super! Danke für Deine Hilfe!

Grüße Booster