VBA Daten zentralisieren für weitere Verwendung
15.07.2019 14:22:36
Tim
ich bin anscheinend zu dämlich nen Thread aus dem Archiv zurück zu holen, bitte steinigt mich nicht. Ich verzweifel momentan an etwas denkbar einfachem und komme mir derweil auch etwas blöd vor. Und zwar verzweifel ich an copy/paste/range.
Im anderen Thread wurde es mit folgendem Makro auf 'gelöst' gesetzt. Leider ist es das nicht. Ich möchte ein Makro welches den kompletten Inhalt eines Tabellenblatts kopiert, auf ein neues einfügt. Dann die nächste Datei öffnen und neben dem eben eingefügten, wieder einfügen. Die Tabellen sollen also nebeneinander angeordnet werden. Der Code zum öffnen aller Excel Dateien aus einem Quellordner ist kein Problem. Weiterhin ist die Codevorlage aber so aufgebaut, dass sie jede Zelle einzeln befüllt. Ist für mich extrem schlecht, da ich so durch bloßes Argumente austauschen nicht gedreht bekomme. Es scheitert bei mir daran, für den nächsten Durchlauf (wenn er eine neue Datei aufruft, die DO Schleife) die Anfangsspalte auf die zuletzt Benutzte + 1 festzulegen.
In der Vorlage wird in jedem Durchlauf jede Zelle einzeln befüllt und die Ergebniszeile dann um einen Wert nach unten gesetzt. Daher funktioniert das auch ganz hervorragend für mehrere Dateien.
Wenn ich nun aber Spalten will - kann man das nicht einfach drehen. Er befüllt ja weiter Zeilenweise, nicht Spaltenweise. Daher muss er solange Zeilen anfügen und füllen, bis eine eine Datei fertig ist. Dann den Anfangswert für die Spalte entsprechend erhöhen und wieder zeilenweise auffüllen... nur wie? Ich komme nicht weiter und bitte um Hilfe ...
Original Code:
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
Sub MWTabellenAusMehrerenDateienEinlesen()
Dim oTargetSheet As Object
Dim oSourceBook As Object
Dim sPfad As String
Dim sDatei As String
Dim lErgebnisZeile As Long
Dim lErgebnisSpalte As Long
Dim s As Long
Dim z As Long
Dim s1 As Long
Application.ScreenUpdating = False 'Das "Flackern" ausstellen
'Schritt 1: Neues Arbeitsblatt für die Ergebnisse erstellen
Set oTargetSheet = ActiveWorkbook.ActiveSheet
lErgebnisZeile = 1 'Ergebnisse eintragen ab Zeile 1
lErgebnisSpalte = 1
'Schritt 2: Schleife über alle Excel Dateien in einem Verzeichnis
sPfad = "C:\Users\halletim\Desktop\Heinz Projekt\"
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(1).UsedRange.Rows.Count
s1 = oSourceBook.Sheets(1).UsedRange.Columns.Count
'Keine Leerzeilen verarbeiten
If Trim(CStr(oSourceBook.Sheets(1).Cells(z, 1).Value)) "" Then
For s = 1 To oSourceBook.Sheets(1).UsedRange.Columns.Count
'Spalte 2 bis n - Tabelleninhalte des Arbeitsblattes 1
oTargetSheet.Cells(lErgebnisZeile, lErgebnisSpalte).Value = _
oSourceBook.Sheets(1).Cells(z, s).Value
Next s
lErgebnisZeile = lErgebnisZeile + 1
End If
Next z
lErgebnisSpalte = s1 + 1
'Schritt 4: Datei wieder zu machen und nächste Schleifenrunde
oSourceBook.Close False 'nicht speichern
'Nächste Datei
sDatei = Dir()
Loop
End Sub
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