VBA - Tabellen waagerecht konsolidieren

Ich habe folgendes Makro zum konsolidieren von Blättern aus versch. Dateien.
Ich würde diese aber waagerecht konsoliedert benötigen (links nach rechts auffüllen) nicht oben nach unten. Leider bekomme ich es einfach nicht hin, die Range zu drehen... irgendwo habe ich einen Denkfehler. Hier der ursprgl Code:
btw. Wäre Klasse, wenn jemand Zeit hat, ... ich würde wirklich gerne verstehen wie ich in Excel eine Range ermittle (last / used row, cell) und die dynamisch konsolidiere. Beispiel:
Tabellenblatt aus erster Datei geht von A:C, das nächste Blatt von A:E
Nun möchte ich natürlich immer variabel nach rechts anfügen also die Inhalte aus dem ersten von A:C übernehmen, die nächsten dann von D:H usw usf. Ich versteh auch den Zeilen / Spalten loop unten nicht wirklich... trotz Vorkentnissen :/
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_datensammeln5.php
' ************************************************************************************************

Sub MWTabellenAusMehrerenDateienEinlesen()
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 alle 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

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub MWTabellenAusMehrerenDateienEinlesen() Dim oTargetSheet As Object Dim oSourceBook As Object Dim sPfad As String Dim sDatei As String Dim lErgebnisSpalte 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 lErgebnisSpalte = 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 alle genutzten Zeilen und Spalten For z = 1 To oSourceBook.Sheets("Tabelle1").UsedRange.Rows.Count 'Keine Leerzeilen verarbeiten 'Spalte 1 - Dateinamen oTargetSheet.Cells(1, lErgebnisSpalte).Value = sDatei If Trim(CStr(oSourceBook.Sheets("Tabelle1").Cells(z, 1).Value)) "" Then For s = 1 To oSourceBook.Sheets("Tabelle1").UsedRange.Columns.Count 'Spalte 2 bis n - Tabelleninhalte des Arbeitsblattes "Tabelle1" lErgebnisSpalte = lErgebnisSpalte + 1 oTargetSheet.Cells(1, lErgebnisSpalte).Value = _ oSourceBook.Sheets("Tabelle1").Cells(z, s).Value Next s lErgebnisSpalte = lErgebnisSpalte + 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

Hallo Regina,
erstmal vielen Dank für das schnelle Umsetzen. Der Code funktioniert leider nur zum Teil. Er schreibt nun alles in Zeile 1. Dafür wird allerdings nun immer schön nach rechts erweitert :)
Ich bräuchte aber das Blatt an sich, aus der Quelle immer 1:1 zu kopiert. In 2D, nicht auf 1D transponiert. also Beispielsweise, zwei Quell-Blätter. Beide erhalten Tabellen unterschiedlicher größen.
Blatt 1: A1:B20,
Blatt 2: A1:C24;
Nun hätte ich die gerne auf einem Blatt konsolidiert, Struktur:
A1:B20 / C1:E24 usw usf. Die Tabellen sollen zweidimensional mit nach rechts angedockt werden. Damit ich im Nachgang mit SVERWEIS / Index-Vergleich immer die für mich relevante Spalte ermitteln und das jeweils benötigte Ergebnis rausziehen kann...

Sub Konsolidieren() Dim fil As File Dim fol As Folder Dim fso As FileSystemObject Dim letzteSpalteQ As Long Dim spalteZ As Long Dim verzeichnis As String Dim wbQ As Workbook ' Q steht für Quelle Dim wbZ As Workbook ' Z steht für Ziel Dim wsQ As Worksheet Dim wsZ As Worksheet Dim zellBereich As Range verzeichnis = "C:\Herber\Test\" Set wbZ = ThisWorkbook Set wsZ = wbZ.Worksheets("Ziel") wsZ.UsedRange.ClearContents Set fso = New FileSystemObject If Not fso.FolderExists(verzeichnis) Then MsgBox "Verzeichnis """ & verzeichnis & """ existiert nicht!" GoTo Ende End If Set fol = fso.GetFolder(verzeichnis) spalteZ = 1 Application.ScreenUpdating = False For Each fil In fol.Files If fil.Name Like "*.xl*" Then Set wbQ = Workbooks.Open(Filename:=verzeichnis & fil.Name, _ UpdateLinks:=False, _ ReadOnly:=True) For Each wsQ In wbQ.Worksheets If WorksheetFunction.CountA(wsQ.Cells) > 0 Then ' Tabellenblatt ist nicht leer ' Die Anzahl der belegten Spalten wird anhand ' der ersten Zeile des Blattes bestimmt letzteSpalteQ = wsQ.Cells(1, wsQ.Columns.Count).End(xlToLeft).Column If spalteZ + letzteSpalteQ > wsZ.Columns.Count Then MsgBox "Maximale Spaltenzahl erreicht" GoTo Ende End If Set zellBereich = wsQ.Range(wsQ.Columns(1), _ wsQ.Columns(letzteSpalteQ)) zellBereich.Copy Destination:=wsZ.Columns(spalteZ) spalteZ = spalteZ + letzteSpalteQ End If Next wsQ wbQ.Close SaveChanges:=False End If Next fil Ende: Set fso = Nothing Application.ScreenUpdating = True End Sub

Beliebteste Forumthreads (12 Monate)

VBA - Tabellen waagerecht konsolidieren

3 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

3
Beiträge zum Forumthread

Beiträge zu diesem Forumthread