Zusammenführen von Tabellen aus mehreren
Arbeitsblättern der geöffneten Arbeitsmappe / Datei zu einer großen Tabelle.
Hierzu habe ich ein kleines Beispiel geschrieben. Einfach entsprechend anpassen und schon haben Sie
eine Automatisierung Ihres Sammelvorgangs realisiert.
Option Explicit
' ************************************************************************************************
' Autor/en: http://www.online-vba.de - Marc Wershoven
' Verwendung der Quelltexte auf eigene Gefahr!
' Es gelten die Nutzungsbedingungen von www.online-vba.de!
' Original-Quelltext: www.online-vba.de/vba_datensammeln7.php
' ************************************************************************************************
Sub MWDatenTabellenAusMehrerenSheetsEinsammeln)
Dim oTargetSheet As Object
Dim oSheet As Object
Dim lErgebnisZeile As Long
Dim i As Long
Dim z As Long
Dim s As Long
Application.ScreenUpdating = False 'Das "Flackern" ausstellen
'Schritt 1: Neues Arbeitsblatt für die Ergebnisse erstellen
Set oTargetSheet = ActiveWorkbook.Sheets.Add
'Alternativ Zuweisung eines bereits vorhandenen Blattes mit vorherigem Löschen
'Set oTargetSheet = ActiveWorkbook.Sheets("VorhandenesBlatt")
'oTargetSheet.Cells.ClearContents 'Nur Inhalte löschen
lErgebnisZeile = 2 'Ergebnisse eintragen ab Zeile 2
'Schritt 2: Schleife über alle Sheets
For Each oSheet In ActiveWorkbook.Sheets
'Schritt 3: Datenübertragung nur wenn nicht das neue Blatt vorliegt
If oSheet.Name <> oTargetSheet.Name Then
'Wenn die Ergebniszeile 2 ist nehmen wir noch einmalig die Tabellenüberschriften mit
If lErgebnisZeile = 2 Then
oTargetSheet.Cells(1, 1).Value = "Quellblatt"
For i = 1 To 10 'überschriften der Spalten 1 bis 10 übertragen
oTargetSheet.Cells(1, i + 1).Value = oSheet.Cells(1, i).Value
Next i
End If
'Eigentliche Datenübertragung - Alle Zeilen der Sheets ab Zeile 2 bis Tabellenende
For z = 2 To oSheet.UsedRange.Rows.Count
'Blattnamen in Spalte 1 eintragen
oTargetSheet.Cells(lErgebnisZeile, 1).Value = CStr(oSheet.Name)
For s = 1 To 10 'Spalten 1 bis 10 übertragen
oTargetSheet.Cells(lErgebnisZeile, s + 1).Value = oSheet.Cells(z, s).Value
Next s
lErgebnisZeile = lErgebnisZeile + 1 'nächste Zeile auf dem Ergebnisblatt
Next z
End If
Next oSheet 'nächstes Arbeitsblatt
Application.ScreenUpdating = True 'Das Bildschirm-Aktualisieren wieder einschalten
'Variablen aufräumen
Set oTargetSheet = Nothing
Set oSheet = Nothing
End Sub
Autor: Marc Wershoven (Mai 2014)
Für alle Nicht-Programmierer gibt es selbstverständlich auch ein komplett fertiges Tool, welches Sie - ohne programmieren zu können -
flexibel auf Ihre Bedürfnisse adaptieren können. Probieren Sie es doch einfach aus!
Zum WershovenOnline® DatenSammlerTool
VBA Programmierer gesucht?
http://www.WershovenOnline.de
Sie haben beispielsweise eine Frage zu einer Ihrer eigenen Makroprogrammierungen in VBA? Oder Sie suchen Unterstützung und Informationen über eine bestimmte Microsoft® Excel® Formel? Bei nahezu allen Fragen und Problemen rund um Microsoft® Office und VBA Makros steht Ihnen unser individueller Quick E-Mail Support zur Verfügung. Einfach, schnell und unkompliziert Ihre Frage in einer E-Mail formulieren, mit oder ohne Screenshots oder einer Beispieldatei absenden und kurze Zeit später haben Sie eine vollständige Lösung inkl. ausführlicher Erklärung vom Profi in Ihrem Postfach!
Zusätzlich besteht die Option, dass wir uns mittels Fernwartung (selbstverständlich nach Ihrem Einvertändnis) direkt "live" mit Ihnen zusammen an Ihrem Bildschirm gemeinsam Fragen und Problemstellungen anschauen und lösen können!
Weitere Informationen zu diesem kostenpflichtigen Angebot finden Sie auf der Anbieterseite von WershovenOnline® auf www.wershovenonline.de.
Zum Anbieter des Quick-E-Mail-Support...