Spalten aus mehreren Excel-Dateien kopieren (Makro)

  • Excel

Es gibt 2 Antworten in diesem Thema. Der letzte Beitrag () ist von kriisz.

    Spalten aus mehreren Excel-Dateien kopieren (Makro)

    Hallo Leute,

    ich möchte verschieden Spalten aus mehreren Dateien in eine Ziel-Tabelle kopieren. Dazu habe ich ein Makro geschrieben, aber habe nicht geschafft, was ich genau wollte.

    Quellcode

    1. Option Explicit
    3. Public Sub Datenuebername()
    5. Const strVerzeichnis As String = "C:\Users\krlaczo\Desktop\Excel\"
    6. Const strTyp As String = "*.xlsx"
    7. Dim strDateiname As String
    8. Dim lngSpalte As Long
    10. Dim wb As Workbook
    12. strDateiname = Dir(strVerzeichnis & strTyp)
    13. Do While Len(strDateiname)
    14. Set wb = Workbooks.Open(Filename:=strVerzeichnis & strDateiname)
    15. wb.Worksheets(1).Range("B:B").Copy
    16. ThisWorkbook.Worksheets(1).Range("B:B").Offset(, lngSpalte).PasteSpecial Paste:=xlPasteValuesAndNumberFormats, _
    17. Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    18. Application.CutCopyMode = False
    19. wb.Close savechanges:=False
    20. strDateiname = Dir
    21. lngSpalte = lngSpalte + 1 'Hier wird bewirkt, dass um eine Spalte nach rechts gerutscht wird
    22. Loop
    23. Set wb = Nothing
    24. End Sub


    Quelle: Spalte A ab Zeile 8 - Ziel: Spalte A ab Zeile 5
    Quelle: Spalte C ab Zeile 8 - Ziel: Spalte B ab Zeile 5
    Es geht so weiter: D->C, E->,F->E und G->F

    Ist es irgendwie möglich?

    Vielen Dank im Voraus.

    Mfg Christian

    Visual Basic-Quellcode

    1. Set = wb.Worksheets(1) 'besser per Sheet-Name oder Objekt-Name adressieren!
    2. Range(wb.Range("A8"),wb.Cells(Rows.Count,1).End(xlUp)).Copy wb.Range("A5") ' Quelle: Spalte A ab Zeile 8 - Ziel: Spalte A ab Zeile 5
    3. Range(wb.Range("C8"),wb.Cells(Rows.Count,3).End(xlUp)).Copy wb.Range("B5") ' Quelle: Spalte C ab Zeile 8 - Ziel: Spalte B ab Zeile 5
    4. Range(wb.Range("D8"),wb.Cells(Rows.Count,4).End(xlUp)).Copy wb.Range("C5") ' D->C

    Ob das Ganze Sinn macht, musst du selbst beurteilen, da du innerhalb einer Tabelle runkopierst und die Daten immer wieder überschreibst.
    Vielleicht solltest du deine Beschreibung nochmals überdenken!
    --
    If Not Program.isWorking Then Code.Debug Else Code.DoNotTouch
    --

    Früher habe ich so geändert, aber funktioniert schon. Wie du jetzt geschrieben hast, kann ich noch anders adressieren. Vielen Dank sonst.

    Quellcode

    1. Private Sub CommandButton1_Click()
    2. Const strVerzeichnis As String = "C:\Users\krlaczo\Desktop\Excel\"
    3. Const strTyp As String = "*.xlsx"
    4. Dim strDateiname As String
    5. Dim lngSpalte As Long
    7. Dim wb As Workbook
    9. strDateiname = Dir(strVerzeichnis & strTyp)
    10. Do While Len(strDateiname)
    11. Set wb = Workbooks.Open(Filename:=strVerzeichnis & strDateiname)
    12. wb.Worksheets(1).Range("A8:A15000").Copy
    13. ThisWorkbook.Worksheets(1).Range("A5:A15000").Offset(, lngSpalte).PasteSpecial Paste:=xlPasteValuesAndNumberFormats, _
    14. Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    15. wb.Worksheets(1).Range("C8:C15000").Copy
    16. ThisWorkbook.Worksheets(1).Range("B5:B15000").Offset(, lngSpalte).PasteSpecial Paste:=xlPasteValuesAndNumberFormats, _
    17. Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    18. Application.CutCopyMode = False
    19. wb.Worksheets(1).Range("D8:D15000").Copy
    20. ThisWorkbook.Worksheets(1).Range("C5:C15000").Offset(, lngSpalte).PasteSpecial Paste:=xlPasteValuesAndNumberFormats, _
    21. Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    22. wb.Worksheets(1).Range("E8:E15000").Copy
    23. ThisWorkbook.Worksheets(1).Range("D5:D15000").Offset(, lngSpalte).PasteSpecial Paste:=xlPasteValuesAndNumberFormats, _
    24. Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    25. wb.Worksheets(1).Range("F8:F15000").Copy
    26. ThisWorkbook.Worksheets(1).Range("E5:E15000").Offset(, lngSpalte).PasteSpecial Paste:=xlPasteValuesAndNumberFormats, _
    27. Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    28. wb.Worksheets(1).Range("G8:G15000").Copy
    29. ThisWorkbook.Worksheets(1).Range("F5:F15000").Offset(, lngSpalte).PasteSpecial Paste:=xlPasteValuesAndNumberFormats, _
    30. Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    31. wb.Close savechanges:=False
    32. strDateiname = Dir
    34. Loop
    35. Set wb = Nothing
    37. End Sub

Facebook
Telefonspende