Inhalte aus Dateien
16.02.2020 15:01:14
Fred
Ich nutze seit längeren ein Script, welches mir Inhalt von Tabellenblatt "Liga" aller Dateien im bestimmten Ordner in mein Tabellenblatt "Gesamt" zusammenfügt.
Klappt im Prinzip.
Was mich ein bischen stört: Die aufgerufenen Dateien sind xlsx,die Inhalte der Tabellenblätter "Liga" haben jeweils ca. 3300 Zeilen, es werden keine Berechnungen durchgeführt und dennoch dauert der Import über 20 Sek., entsprechend lange, wenn ich über 20 Dateien mit solch einem Tabellenblatt im Ordner habe.
Meine Anfrage;
Kann sich mal jemand bitte das Script anschauen, evt. auf Tempo verbessern/optimieren?
Das Script
Sub Tabellen_aus_Dateien()
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
Set oTargetSheet = ActiveWorkbook.Sheets("Gesamt")
lErgebnisZeile = 10 'Ergebnisse eintragen ab Zeile 10
'Schritt 2: Schleife über alle Excel Dateien in einem Verzeichnis
sPfad = "C:\Users\Fred Neumann\Desktop\Blog\Strategie1\03_5Jahre\"
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 = 3 To oSourceBook.Sheets("Liga").UsedRange.Rows.Count
'Keine Leerzeilen verarbeiten
If Trim(CStr(oSourceBook.Sheets("Liga").Cells(z, 3).Value)) "" Then
For s = 1 To oSourceBook.Sheets("Liga").UsedRange.Columns.Count
'Spalte 1 - Dateinamen
oTargetSheet.Cells(lErgebnisZeile, 1).Value = sDatei
'Spalte 2 bis n - Tabelleninhalte des Arbeitsblattes "Gesamt"
oTargetSheet.Cells(lErgebnisZeile, s + 1).Value = _
oSourceBook.Sheets("Liga").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
Fred