VBA - gezielte Daten aus mehreren Dateien zusammenführen
31.01.2020 13:03:58
Markus
ich bastel gerade an einer Daten-Konsolidierung. Hierfür möchte ich einen definierten Zellenbereich aus "n" verschiedenen Quell-Dateien untereinander weg in eine Zieldatei schreiben. Habe mir bereits mittels diverser Forenbeiträge und Tutorials einen kleinen VBA Code zusammen gebaut. Die Struktur und Benennung bei allen Quelldateien ist immer gleich, jedoch gibt es mal mehr und mal weniger Quelldateien.
was bisher funktioniert:
- Abfrage des Pfades, wo die Quell-Dateien liegen
- kopieren des definierten Zellenbereiches eines bestimmten Tabellenblattes der Quelldateien
- einfügen auf einem vorgesehenen Tabellenblatt der Zieldatei als Werte
was fehlt:
die Zellen der nächste Quelle-Datei werden bis jetzt an gleicher Stelle in die Zieldatei hineinkopiert. Eigentlich müssten die unterhalb des letzten Eintrages eingefügt werden. habe es aber mit "NextRow = Cells(Rows.Count, 5).End(xlUp).Row + 1 " nicht zusammenbringen können. Die letzte Zeile sollte dabei anhand der Spalte E ermittelt werden, da in anderen Bereich bereits Formeln bis ziemlich weit nach unten eingetragen sind.
zur Info:
Der Bereich D7:D46 beinhaltet in der Quelle die eingetlichen Datensätze und soll in der Zieldatei ab Spalte E eingetragen werden. Dieser Bereich ist fix in alle Quellen und ändert sich auch nicht von der Zeilen-Anzahl. Der Name der Quell-Datei soll zwecks Zuordnung der Datensätze aus Zelle AE2 der Quelldatei übernommen werden und in Spalte D vor jedem der zugehörigen Datenzeilen eingetragen werden.
Mein Code bisher
Sub Dateien_importieren()
Dim Zielarbeitsmappe As Object
Dim Quelle As Object
Dim pfad As String
Dim datei As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set Zielarbeitsmappe = ActiveWorkbook
pfad = InputBox("Pfad bitte per copy & paste einfügen", "Pfad der Quell-Dateien") & "\"
datei = Dir(CStr(pfad & "*xl*"))
Do While datei ""
Set Quelle = Workbooks.Open(pfad & datei, False, True)
Quelle.Sheets(3).Range("D7:CD46").Copy
Zielarbeitsmappe.Sheets("input_reply_dataset").Cells(5, 5).PasteSpecial xlPasteValues
Quelle.Sheets(3).Range("AE2:AE2").Copy
Zielarbeitsmappe.Sheets("input_reply_dataset").Range("D5:D44").PasteSpecial xlPasteValues
Quelle.Close
datei = Dir()
Loop
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Set Zielarbeitsmappe = Nothing
Set Quelle = Nothing
MsgBox "Dateien wurden erfolgreich übernommen"
End Sub
Hoffe, ich konnte mein Problem ausführlich genug schildern und das Teile meines bisherigen Codes auch anderen anderen weiterhelfen kann :)
Ciao, Markus