Tabellen aus offenen Dateien sammeln
Ausgangslage - Was tut dieser Code-Schnipsel?
Ein immer wieder beliebtes Thema und eine andere Variante, diesmal aus geöffneten Dateien:
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-offenen-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_TabellenAusMehrerenOffenenDateienEinlesen()
Dim oTargetSheet As Object
Dim oSoureWorkbook As Object
Dim oTargetWorkbook As Object
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 oTargetWorkbook = ActiveWorkbook
Set oTargetSheet = ActiveWorkbook.Sheets.Add
lErgebnisZeile = 1 'Ergebnisse eintragen ab Zeile 1
'Schritt 2: Schleife über alle offenen Arbeitsmappen und Datenübertragung
For Each oSoureWorkbook In Application.Workbooks
If oTargetWorkbook.Name <> oSoureWorkbook.Name Then
'Datenübertragung aller genutzten Zeilen und Spalten
For z = 1 To oSoureWorkbook.Sheets("Tabelle1").UsedRange.Rows.Count
'Keine Leerzeilen verarbeiten
If Trim(CStr(oSoureWorkbook.Sheets("Tabelle1").Cells(z, 1).Value)) <> "" Then
For s = 1 To oSoureWorkbook.Sheets("Tabelle1").UsedRange.Columns.Count
'Spalte 1 - Dateinamen
oTargetSheet.Cells(lErgebnisZeile, 1).Value = oSoureWorkbook.Name
'Spalte 2 bis n - Tabelleninhalte des Arbeitsblattes "Tabelle1"
oTargetSheet.Cells(lErgebnisZeile, s + 1).Value = _
oSoureWorkbook.Sheets("Tabelle1").Cells(z, s).Value
Next s
lErgebnisZeile = lErgebnisZeile + 1
End If
Next z
End If
Next oSoureWorkbook
Application.ScreenUpdating = True 'Das Bildschirm-Aktualisieren wieder einschalten
'Variablen aufräumen
Set oTargetSheet = Nothing
Set oSoureWorkbook = Nothing
Set oTargetWorkbook = 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.
