Tabellen in einer Tabelle sammeln, inkl. Formatier
17.01.2017 20:42:15
Christian
Ich füge alle Exceltabellen aus einem Verzeichnis in einer Tabelle zusammen. Leider werden die Formatierungen nicht übernommen. Ich brauche Hilfe.
Mein Code:
Option Explicit
Sub MWTabellenAusMehrerenDateienEinlesen()
Dim oTargetSheet As Object
Dim oSourceBook As Object
Dim sPfad As String
Dim sDatei As Long
Dim lErgebnisZeile As Long
Dim s As Long
Dim z As Long
Application.ScreenUpdating = False 'Das "Flackern" ausstellen
GetMoreSpeed (True) ' Startet mdl_beschleunigung ***
'Bevor kopiert wird, muss die Tabelle "Übersicht" ab Zeile 5 gelöscht werden.
With Worksheets("Übersicht")
.Range(.Cells(5, 1), .Cells(.Rows.Count, 1)).EntireRow.Delete
End With
'Schritt 1: Arbeitsblatt festlegen in welches die gesammelten Daten geschrieben werden _
sollen
Set oTargetSheet = ActiveWorkbook.Sheets("Übersicht")
lErgebnisZeile = 5 'Ergebnisse eintragen ab Zeile 5
'Schritt 2: Schleife über alle Excel Dateien in einem Verzeichnis
sPfad = "P:AuftragserstellungAuftragsablage"
sDatei = Dir(CStr(sPfad & "*xlsx")) 'nur xlsx Dateien '(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 der Quelldateien sPfad
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 der Quelldateiein in Spalte A eintragen.
oTargetSheet.Cells(lErgebnisZeile, 1).Value = sDatei
'ab Spalte 2 bis n - Tabelleninhalte des Arbeitsblattes "Übersicht" _
eintragen
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
GetMoreSpeed (False) ' Startet mdl_beschleunigung ***
'Variablen aufräumen
Set oTargetSheet = Nothing
Set oSourceBook = Nothing
End Sub