Tabellen aus Dateien sammeln
Ausgangslage - Was tut dieser Code-Schnipsel?
Ein immer wieder beliebtes Thema und eine andere Variante: Zusammenführen von
Tabellen aus mehreren anderen Arbeitsmappen / Dateien in ein neues Tabellenblatt.
Hierzu habe ich ein kleines Beispiel geschrieben. Einfach entsprechend anpassen und schon haben Sie
eine Automatisierung Ihres Sammelvorganges realisiert.
Es werden alle Zeilen / Spalten des genutzten Bereiches der Tabellen ohne evtl. vorhandener
Leerzeilen übernommen. Die Spalte 1 muss entsprechend gefüllt sein, da diese als
Erkennungsmerkmal einer gefüllten Zeile dient (Sie können die Spalte aber im Quelltext ändern!).
Der Quelltext
Option Explicit
' Original-Quelltext unter: https://www.online-vba.de/tabellen-aus-dateien-sammeln
' Express-Hilfe für VBA unter https://www.online-vba.de/vba-expresshilfe
' Es gelten die Nutzungsbedingungen von Online-VBA.de
Public Sub OVBAde_TabellenAusMehrerenDateienEinlesen()
Dim oTargetSheet As Object
Dim oSourceBook As Object
Dim sPfad As String
Dim sDatei As String
Dim lErgebnisZeile As Long
Dim s As Long
Dim z As Long
Application.ScreenUpdating = False 'Das "Flackern" ausstellen
'Schritt 1: Neues Arbeitsblatt für die Ergebnisse erstellen
Set oTargetSheet = ActiveWorkbook.Sheets.Add
lErgebnisZeile = 1 'Ergebnisse eintragen ab Zeile 1
'Schritt 2: Schleife über alle Excel Dateien in einem Verzeichnis
sPfad = "C:\TEST\Sammlung\"
sDatei = Dir(CStr(sPfad & "*.xl*")) 'Alle Excel Dateien
Do While sDatei <> ""
'Schritt 3: Öffnen der Datei und Datenübertragung
Set oSourceBook = Workbooks.Open(sPfad & sDatei, False, True) 'nur lesend öffnen
'Datenübertragung aller genutzten Zeilen und Spalten
For z = 1 To oSourceBook.Sheets("Tabelle1").UsedRange.Rows.Count
'Keine Leerzeilen verarbeiten
If Trim(CStr(oSourceBook.Sheets("Tabelle1").Cells(z, 1).Value)) <> "" Then
For s = 1 To oSourceBook.Sheets("Tabelle1").UsedRange.Columns.Count
'Spalte 1 - Dateinamen
oTargetSheet.Cells(lErgebnisZeile, 1).Value = sDatei
'Spalte 2 bis n - Tabelleninhalte des Arbeitsblattes "Tabelle1"
oTargetSheet.Cells(lErgebnisZeile, s + 1).Value = _
oSourceBook.Sheets("Tabelle1").Cells(z, s).Value
Next s
lErgebnisZeile = lErgebnisZeile + 1
End If
Next z
'Schritt 4: Datei wieder zu machen und nächste Schleifenrunde
oSourceBook.Close False 'nicht speichern
'Nächste Datei
sDatei = Dir()
Loop
Application.ScreenUpdating = True 'Das Bildschirm-Aktualisieren wieder einschalten
'Variablen aufräumen
Set oTargetSheet = Nothing
Set oSourceBook = Nothing
End Sub
Anmerkungen und Hinweise
Dieser Codeschnipsel wurde geschrieben von Marc Wershoven im Jahr 2013.
Die Nutzung erfolgt auf eigene Gefahr.
Bitte denken Sie immer zuerst an eine ausreichende Datensicherung.
Wir können keinen kostenlosen Support anbieten.
Es gelten unsere Nutzungsbedingungen.
