Einzelne Zeilen in neue .xls exportieren

  • Excel

Es gibt 5 Antworten in diesem Thema. Der letzte Beitrag () ist von mtoebben.

    Einzelne Zeilen in neue .xls exportieren

    Hallo zusammen,

    ich würde gerne ein VB-Script schreiben, welches aus einer vorhanden Excel-Datei einzelne Zeilen in neue .xls exportiert.
    So soll z.B. eine Exceldatei mit insgesamt 1000 Zeilen in entsprechend 1000 Excel-Dateien aufgesplittet werden (1 Zeile pro Datei).
    Optimal wäre es, wenn diese Datei sich zudem automatisch nach einer Zelle innerhalb der Zeile benennt, sprich eine Zelle innerhalb der Zeile enthält Text, welcher beim Export als Dateinnamen (XYZ.xls) verwendet werden soll.

    Kann mir damit vielleicht jemand helfen? Die Erfahrung reicht leider (bislang) noch nicht :)

    Besten Dank vorab,
    Mathias

    Visual Basic-Quellcode

    1. Sub blubb()
    3. Const cPfad As String = "C:\TEMP\"
    4. Dim i As Long
    5. Dim wb As Workbook
    6. Dim ws, wbSRC As Worksheet
    8. Set wbSRC = ActiveSheet 'In deiner Mappe mit allen Zeilen..
    10. For i = 1 To 1000
    11. Set wb = Workbooks.Add
    12. Set ws = wb.Sheets(1)
    13. ws.Rows(1).Value = wbSRC.Rows(i).Value
    14. wb.Close SaveChanges:=True, Filename:= _
    15. CStr(cPfad & wbSRC.Range("A" & i).Value & ".xls")
    16. Set ws = Nothing
    17. Set wb = Nothing
    18. Next
    20. Set wbSRC = Nothing
    22. MsgBox "ok"
    24. End Sub

    Hallo zusammen,

    nochmal eine kleine Frage hierzu:

    Visual Basic-Quellcode

    1. Sub blubb()
    3. Const cPfad As String = "file://localhost/Users/mtoebben/Desktop/Test/"
    4. Dim i As Long
    5. Dim wb As Workbook
    6. Dim ws, wbSRC As Worksheet
    8. Set wbSRC = ActiveSheet 'In deiner Mappe mit allen Zeilen..
    10. For i = 2 To 2
    11. Set wb = Workbooks.Add
    12. Set ws = wb.Sheets(1)
    13. ws.Rows(1).Value = wbSRC.Rows(1).Value
    14. ws.Rows(1).Font.Bold = True
    15. ws.Rows(2).Value = wbSRC.Rows(i).Value
    16. wb.Close SaveChanges:=True, Filename:= _
    17. CStr(cPfad & wbSRC.Range("A" & i).Value & ".xls")
    18. Set ws = Nothing
    19. Set wb = Nothing
    20. Next
    22. Set wbSRC = Nothing
    24. MsgBox "ok"
    26. End Sub


    Gerne würde ich die Formatierung der Rows mit in die neue Datei übernehmen. Scheint mit copy/paste special irgendwie nicht zu funktionieren :-/

    Kann mir da jemand weiterhelfen? Wäre toll!

    Veieln Dank!
    Mathias

    Visual Basic-Quellcode

    1. Sub blubb()
    3. Const cPfad As String = "file://localhost/Users/mtoebben/Desktop/Test/"
    4. Dim i As Long
    5. Dim wb As Workbook
    6. Dim ws, wbSRC As Worksheet
    8. Set wbSRC = ActiveSheet 'In deiner Mappe mit allen Zeilen..
    10. For i = 2 To 4
    11. Set wb = Workbooks.Add
    12. Set ws = wb.Sheets(1)
    13. wbSRC.Rows(1).Copy ws.Rows(1) 'Header immer
    14. wbSRC.Rows(i).Copy ws.Rows(2) 'Daten
    15. wb.SaveAs _
    16. Filename:=CStr(cPfad & _
    17. wbSRC.Range("A" & i).Value & ".xls"), _
    18. FileFormat:=xlExcel8
    19. wb.Close SaveChanges:=False
    20. Set ws = Nothing
    21. Set wb = Nothing
    22. Next
    24. Set wbSRC = Nothing
    26. MsgBox "ok"
    28. End Sub

    Spitze! Vielen Dank!!!! :)

    Habe noch ne autofit-Funktion eingebaut und jetzt ist es optimal!

    Visual Basic-Quellcode

    1. Sub blubb()
    3. Const cPfad As String = "file://localhost/Users/mtoebben/Desktop/Test/"
    4. Dim i As Long
    5. Dim wb As Workbook
    6. Dim ws, wbSRC As Worksheet
    8. Set wbSRC = ActiveSheet 'In deiner Mappe mit allen Zeilen..
    10. For i = 2 To 4
    11. Set wb = Workbooks.Add
    12. Set ws = wb.Sheets(1)
    13. wbSRC.Rows(1).Copy ws.Rows(1) 'Header immer
    14. wbSRC.Rows(i).Copy ws.Rows(2) 'Daten
    15. ws.Rows(2).EntireColumn.AutoFit
    16. wb.SaveAs _
    17. Filename:=CStr(cPfad & _
    18. wbSRC.Range("A" & i).Value & ".xls"), _
    19. FileFormat:=xlExcel8
    20. wb.Close SaveChanges:=False
    21. Set ws = Nothing
    22. Set wb = Nothing
    23. Next
    25. Set wbSRC = Nothing
    27. MsgBox "ok"
    29. End Sub


    Vielen Dank für die Hilfe!

    Liebe Grüße,
    Mathias

Facebook
Telefonspende