Daten mehrer Excel Dateien mittels Makro in eine neue Datei importieren

  • Excel

Es gibt 16 Antworten in diesem Thema. Der letzte Beitrag () ist von Tobias.

    Daten mehrer Excel Dateien mittels Makro in eine neue Datei importieren

    Hallo,

    ich bin Anfänger was die Makro Programmierung im Excel betrifft und stehe komplett an! Ich habe leider die passende Antwort für mich im Forum nicht gefunden, weshalb ich ein eigenes Thema eröffnet habe.

    Mein Ziel ist es, aus mehreren Excel Dateien Informationen mittels Makro Programmierung in ein neues File zu bekommen. Es handelt sich in den unterschiedlichen Excel Files immer um die gleiche Arbeitsblattbezeichnung und die gleichen Zeilen (es sind mehrere Zeilen pro Arbeitsblatt z.B.: Zeile 13, 17,19).
    Ich habe im Forum folgendes gefunden und so gut wie möglich angepasst:

    Sub LoopThroughDirectory()
    Dim MyFile As String
    Dim erow
    Dim Filepath As String
    Filepath = "C:\Users\harald\Documents\Files\"
    MyFile = Dir(Filepath)
    Do While Len(MyFile) > 0
    If MyFile = "C:\Users\harald\Documents\Files\Masterfile.xlsm" Then
    Exit Sub
    End If

    Workbooks.Open (Filepath & MyFile)
    Range("A10:F10").Copy
    ActiveWorkbook.Close

    erow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
    ActiveSheet.Paste Destination:=Worksheets("Sheet1").Range(Cells(erow, 1), Cells(erow, 4))

    MyFile = Dir
    Loop
    End Sub




    Jedoch gibt es mir immer einen Fehler 424 bei der rot markierten Zeile aus. Des Weiteren ist diese Programmierung zur Zeit darauf ausgelegt, immer nur eine Zeile von einer Datei in ein neues File zu kopieren. Ich benötige jedoch mehrere.

    Es wäre toll wenn mir jemand helfen könnte!

    Vielen Dank schon im Voraus

    Lg
    HTRM

    Visual Basic-Quellcode

    1. Option Explicit
    2. Sub FillFromDirectory()
    3. Dim Filepath As String, MyFile As String, wb As Workbook, ws As Worksheet
    4. Filepath = "C:\temp\"
    5. MyFile = Dir(Filepath)
    6. Do While Len(MyFile) > 0
    7. If MyFile Like "*.xls?" And MyFile <> "Masterfile.xlsm" Then
    8. Set wb = Workbooks.Open(Filepath & MyFile, UpdateLinks:=False, ReadOnly:=True)
    9. Set ws = wb.Sheets("Tabelle1")
    10. ws.Range("A13:F13").Copy NextRow
    11. ws.Range("A17:F17").Copy NextRow
    12. ws.Range("A19:F19").Copy NextRow
    13. wb.Close False
    14. End If
    15. MyFile=Dir
    16. Loop
    17. End Sub
    18. Private Function NextRow() As Range
    19. Set NextRow = Cells(Rows.Count, 1).End(xlUp).Offset(1)
    20. End Function
    Der Code gehört übrigens in den Codebereich des Ziel-Arbeitsblatts

    Ich habe in deiner Aufgabenstellung nur nicht gelesen, was passieren soll, wenn du das Script zum zweiten Mal ausführst.
    Vielleicht solltest du darauf achten, dass du bereits eingelesene Dateien entsprechend markierst oder löschst.


    Edit:
    Es geht noch etwas universeller:

    Visual Basic-Quellcode

    1. Option Explicit
    2. Const FilePath = "C:\temp\"
    3. Const CopyRange = "A13:F13,A17:F17,A19:F19"
    4. Sub FillFromDirectory()
    5. Dim MyFile As String, wb As Workbook, ws As Worksheet, Rng As Variant
    6. MyFile = Dir(FilePath)
    7. Do While Len(MyFile) > 0
    8. If MyFile Like "*.xls?" And MyFile <> "Masterfile.xlsm" Then
    9. Set wb = Workbooks.Open(FilePath & MyFile, UpdateLinks:=False, ReadOnly:=True)
    10. Set ws = wb.Sheets("Tabelle1")
    11. For Each Rng In Split(CopyRange, ",")
    12. ws.Range(Rng).Copy Cells(Rows.Count, 1).End(xlUp).Offset(1)
    13. Next
    14. wb.Close False
    15. End If
    16. MyFile = Dir
    17. Loop
    18. End Sub
    --
    If Not Program.isWorking Then Code.Debug Else Code.DoNotTouch
    --

    Dieser Beitrag wurde bereits 4 mal editiert, zuletzt von „petaod“ ()

    Hallo petaod,

    vielen Dank für deine Hilfe!

    Sorry für die späte Rückmeldung, war auf Dienstreise.

    Ich habe deine Codes nun probiert:

    Sub FillFromDirectory()
    Dim Filepath As String, MyFile As String, wb As Workbook, ws As Worksheet
    Filepath = "C:\Users\harald\Documents\Files\Test"
    MyFile = Dir(Filepath)
    Do While Len(MyFile) > 0
    If MyFile Like "*.xls?" And MyFile <> "Masterfile.xlsm" Then
    Set wb = Workbooks.Open(Filepath & MyFile, UpdateLinks:=False, ReadOnly:=True)
    Set ws = wb.Sheets("Tabelle1")
    ws.Range("A13:F13").Copy NextRow
    ws.Range("A17:F17").Copy NextRow
    ws.Range("A19:F19").Copy NextRow
    wb.Close False
    End If
    MyFile = Dir
    Loop
    End Sub
    Private Function NextRow() As Range
    Set NextRow = Cells(Rows.Count, 1).End(xlUp).Offset(1)
    End Function

    Was habe ich gemacht;
    Unter Filepath habe ich den Pfad angegeben wo die Ordner liegen. Das war es!
    Hab ich etwas vergessen? Ich habe wie von dir geschrieben natürlich den Code in das Zielverzeichnis kopiert. Das wurmt mich echt, dass ich so wenig Ahnung vom Programmieren habe!!!

    Zu deiner Frage: Ich muss die Daten nicht öfters aktualisieren. Ich werde ungefähr 80 Excel Dateien bekommen und davon muss ich bestimmte Datenfelder gesammelt in ein neues Spielen. Es ist somit keine Aktualisierung notwendig.

    Danke auf jeden Fall für deine Hilfe!

    Beste Grüße
    HTRM
    Hallo, vielleicht ließt noch jemand mit :). Ich habe das Skript genommen und es läuft fantastisch!!! Das einzige was für meine Zwecke nicht klappt ist, dass die Zellen die kopiert werden Formeln enthalten und nur der Inhalt kopiert werden soll. Da ich leider nicht verstehe an welcher Stelle das Einfügen stattfindet (vermut irgendwo hier: For Each Rng In Split(CopyRange, ",")
    ws.Range(Rng).Copy Cells(Rows.Count, 1).End(xlUp).Offset(1) ) bekomme ich das nicht hin. Habe die zweite Version genommen :).

    Vielen Dank für die Hilfe!!!
    @cry.baby
    Wird so wohl nicht funktionieren.
    Rng ist ein Range aus mehreren Zellen, die du ggf. einzeln behandeln musst.

    Oder den DestinationRange entsprechend passend erweitern.
    Stichwort: ReSize

    Alternativ ginge auch eine Kombination aus Copy und PasteValues.
    Belegt halt den PasteBuffer und ist deshalb durch Ausseneinflüsse gefährdet.
    --
    If Not Program.isWorking Then Code.Debug Else Code.DoNotTouch
    --
    Hallo cry.baby, hallo petaod,

    danke für die schnelle Rückmeldung und Hilfe!

    Visual Basic-Quellcode

    1. For Each Rng In Split(CopyRange, ",")
    2. ws.Range(Rng).Copy Cells(Rows.Count, 1).End(xlUp).Offset(1)
    3. Next


    durch

    Visual Basic-Quellcode

    1. For Each Rng In Split(CopyRange, ",")
    2. Cells(Rows.Count, 1).End(xlUp).Offset(1) = ws.Range(Rng).Value
    3. Next


    ersetzt (also nur die zweite Zeile angepasst), und jetzt kopiert er nichts mehr. Hättet Ihr noch eine andere Idee, bzw. wie eine Kombination aus Copy und PasteValues konkret auszusehen hätte? Das hier eine Gefährdung durch Ausseneinflüsse besteht wäre für mich erstmal nachrangig.

    Danke für die Hilfe!!

    Tobias schrieb:

    Das hier eine Gefährdung durch Ausseneinflüsse besteht wäre für mich erstmal nachrangig.
    Für dich vielleicht.
    Aber ich publiziere hier keine unsauberen Lösungen, wenn es sich vermeiden lässt.
    Ich habe drei Lösungsmöglichkeiten angesprochen und du springst jetzt auf die auf, von der ich abrate.

    Eigentlich hätte ich erwartet, dass die Stichworte als Hilfestellung genügen.
    Aber ich muss es wohl doch vorkauen.

    Die eleganteste der Lösungen:

    Visual Basic-Quellcode

    1. For Each Rng In Split(CopyRange, ",")
    2. Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(Range(Rng).Rows.Count, Range(Rng).Columns.Count).Value = Range(Rng).Value
    3. Next
    Das lässt sich auch noch schöner schreiben, wenn man Range(Rng) in eine Variable packt.
    Aber du brauchst ja auch noch etwas Arbeit.
    --
    If Not Program.isWorking Then Code.Debug Else Code.DoNotTouch
    --
    Also wenn Du mit der unsauberen Lösung leben kannst, dann sollte es so gehen:

    Visual Basic-Quellcode

    1. For Each Rng In Split(CopyRange, ",")
    2. ws.Range(Rng).Copy
    3. Cells(Rows.Count, 1).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
    4. Next
    5. Application.CutCopyMode = False


    Aber die Transfer Methode von Petaod ist auf jeden Fall besser, weil auch schneller.
    Vielen Dank für die Unterstützung. Wollte gar nicht die unsaubere Lösung bevorzugt nehmen, dachte die wäre vielleicht wesentlich einfacher (muss gestehen, ich verstehe diese Art von VBA Funktion gar nicht, ich verstehe nach wie vor nicht, wann er EINFÜGT, das hier soll aber keine DAU-Einführung werden ;) ).

    Den Code von petaod habe ich noch um die "ws.Range..." Zeile ergänzt, so das die jetzt wie folgt aussieht:

    Visual Basic-Quellcode

    1. For Each Rng In Split(CopyRange, ",")
    2. ws.Range(Rng).Copy
    3. Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(Range(Rng).Rows.Count, Range(Rng).Columns.Count).Value = Range(Rng).Value
    4. Next


    Klappt aber leider noch nicht (egal ob damit oder Ohne, wobei das vielleicht auch gar nicht da hin gehört).

    Mit dem Code von cry.baby hat es geklappt. Vielen Dank fürs Vorkauen!

    Solltet Ihr noch Lust haben, wäre ich dankbar wenn Ihr noch erklären könntet, warum die an sich elegantere Lösung nicht läuft, möchte Euch aber nicht die Zeit stehlen.

    Vielen Dank!!!

    Tobias schrieb:

    wann er EINFÜGT
    Er fügt nicht ein.
    Durch das = wird dem einem Zellbereich die Werte des anderen Zellbereichs zugewiesen.

    Tobias schrieb:

    Den Code von petaod habe ich noch um die "ws.Range..." Zeile ergänzt
    Warum?

    Tobias schrieb:

    warum die an sich elegantere Lösung nicht läuft
    Das kann ich nicht nachvollziehen.
    In welcher Zeile gibt es Probleme?
    Gibt es eine Fehlermeldung?
    Was ist der Inhalt von CopyRange?
    Verwendest du verbundene Zellen?

    Weißt du, wie man den Debugger bedient?
    --
    If Not Program.isWorking Then Code.Debug Else Code.DoNotTouch
    --
    In welcher Zeile gibt es Probleme?​

    In keiner Das Script läuft durch, man sieht wie er die anderen Dateien öffnet und schließt, kopiert aber nichts in die Zieldatei.

    ​Gibt es eine Fehlermeldung?

    Nein, keine Fehlermeldung.

    ​Was ist der Inhalt von CopyRange?

    Bin mir nicht sicher wie ich das feststellen kann.

    ​Verwendest du verbundene Zellen?

    Nein.

    ​Weißt du, wie man den Debugger bedient?

    Leider nicht (habe gerade ein wenig damit rumgespielt, kam aber auch nichts richtiges raus.

    Ich habe alles in eine Datei mit zwei Test-"Export"-Dateien zusammengepackt. Darf man hier links zu One-Click Hostern posten, bzw. würdet Ihr Euch das runterladen wenn ich es bereit stelle?

    Tobias schrieb:

    Ich habe alles in eine Datei mit zwei Test-"Export"-Dateien zusammengepackt
    Klicke auf "Erweiterte Antwort" und hänge eine ZIP-Datei als Anhang dran.

    Tobias schrieb:

    Bin mir nicht sicher wie ich das feststellen kann.


    Tobias schrieb:

    Bin mir nicht sicher wie ich das feststellen kann.
    Indem du im Debugger schrittweise voran gehst und dann den Mauszeiger über die Variable (bzw. Konstante) gehst.
    Es sollte allerdings bei dir offensichtlich sein, weil du die Konstante im Code direkt füllst.

    Den Debugger zu kennen ist das A&O bei der Programmentwicklung.
    Da solltest du dich unbedingt mit befassen.
    vba-tutorial.de/fehler/debuggen.htm
    --
    If Not Program.isWorking Then Code.Debug Else Code.DoNotTouch
    --
    Du willst aus einem fremden Sheet kopieren, dann muss die Source in deinem Code natürlich entsprechend angepasst werden:
    Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(Range(Rng).Rows.Count, Range(Rng).Columns.Count).Value = ws.Range(Rng).Value

    Dein kompletter Code sieht bei mir so aus:

    Visual Basic-Quellcode

    1. ​Option Explicit
    2. Const CopyRange = "B13:F19" 'comma separated list of address ranges, e.g. "A1:B1,A3:B3"
    3. Sub FillFromDirectory()
    4. Dim FilePath As String, MyFile As String, wb As Workbook, ws As Worksheet, Rng As Variant
    5. FilePath = ThisWorkbook.Path & "\"
    6. MyFile = Dir(FilePath)
    7. Do While Len(MyFile) > 0
    8. If MyFile Like "*.xls?" And MyFile <> ThisWorkbook.Name Then
    9. Set wb = Workbooks.Open(FilePath & MyFile, UpdateLinks:=False, ReadOnly:=True)
    10. Set ws = wb.Sheets(1)
    11. For Each Rng In Split(CopyRange, ",")
    12. Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(Range(Rng).Rows.Count, Range(Rng).Columns.Count).Value = ws.Range(Rng).Value
    13. Next
    14. wb.Close False
    15. End If
    16. MyFile = Dir
    17. Loop
    18. End Sub
    --
    If Not Program.isWorking Then Code.Debug Else Code.DoNotTouch
    --

    Dieser Beitrag wurde bereits 1 mal editiert, zuletzt von „petaod“ ()