Auslesen mehrerer Exceldateien

Hallo zusammen,
ich möchte Daten aus mehreren Excel-Dateien auslesen und in einer bestehenden Zieldatei, in einem Tabellenblatt fortlaufend einfügen. Ich habe dafür einen Code im Netz gefunden, der auch soweit ganz gut funktioniert. Allerdings dauert die Prozedur bei mehreren Dateien relativ lange. Ich habe mir sagen lassen, dass es daran liegt, dass das Makro einzelne Zellen kopiert und einfügt bzw. über Zeilen und Spalten geht. Es soll wohl besser sein, wenn das Makro einfach die jeweils genutzten Zeilen der Quelldateien ausließt und in die Zieldatei einfügt.
Ich habe jetzt schon mehrere Tage vergeblich versucht den Code entsprechend umzubauen. Meine VBA Kentnisse reichen hierfür leider nicht aus.
Gibt es hier eventuell liebe Menschen, die mir den Code wie oben beschrieben anpassen könnten?
Hier der aktuelle, funktionierende aber sehr langsame Code:


Sub DateienEinlesen()
On Error GoTo Err
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: Arbeitsblatt für die Ergebnisse
Set oTargetSheet = ThisWorkbook.Sheets("Bestellkonsolidierung")
lErgebnisZeile = 2 'Ergebnisse eintragen ab Zeile 1
'Schritt 2: Schleife über alle Excel Dateien in einem Verzeichnis
sPfad = InputBox("Bitte Pfad eingeben", "Pfad") & "\"
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 = 2 To oSourceBook.Sheets("Data").UsedRange.Rows.Count
'Keine Leerzeilen verarbeiten
If Trim(CStr(oSourceBook.Sheets("Data").Cells(z, 1).Value))  "" Then
For s = 1 To oSourceBook.Sheets("Data").UsedRange.Columns.Count
'Spalte 1 - Dateinamen
oTargetSheet.Cells(lErgebnisZeile, 1).Value = sDatei
'Spalte 2 bis n - Tabelleninhalte des Arbeitsblattes "Tabelle1"
oTargetSheet.Cells(lErgebnisZeile, s + 3).Value = _
oSourceBook.Sheets("Data").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
ThisWorkbook.Sheets("Bestellkonsolidierung").Select
Exit Sub
Err:
MsgBox "Fehler in Sub" & Err.Number & ": " & Err.Description, vbCritical + vbOKOnly
End Sub

Ich würde mich sehr freuen, wenn mir jemand helfen könnte.
Vorab vielen Dank und viele Grüße
Alex

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub DateienEinlesen() On Error GoTo Err 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: Arbeitsblatt für die Ergebnisse Set oTargetSheet = ThisWorkbook.Sheets("Bestellkonsolidierung") lErgebnisZeile = 2 'Ergebnisse eintragen ab Zeile 1 'Schritt 2: Schleife über alle Excel Dateien in einem Verzeichnis sPfad = InputBox("Bitte Pfad eingeben", "Pfad") & "\" 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 = 2 To oSourceBook.Sheets("Data").UsedRange.Rows.Count 'Keine Leerzeilen verarbeiten If Trim(CStr(oSourceBook.Sheets("Data").Cells(z, 1).Value)) "" Then For s = 1 To oSourceBook.Sheets("Data").UsedRange.Columns.Count 'Daten in Zieldatei schreiben oTargetSheet.Cells(2, 1).Resize(30).Value = _ oSourceBook.Sheets("Data").Cells(2, 1).Resize(30).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 ThisWorkbook.Sheets("Bestellkonsolidierung").Select Exit Sub Err: MsgBox "Fehler in Sub" & Err.Number & ": " & Err.Description, vbCritical + vbOKOnly End Sub Sub Überschriften() On Error GoTo Err 'Überschriften löschen Dim i As Long Dim Zielsheet As Object 'Auswahl Zieltabelle ActiveWorkbook.Sheets("Bestellkonsolidierung").Select Set Zielsheet = ActiveWorkbook.Sheets("Bestellkonsolidierung") Application.ScreenUpdating = False For i = Zielsheet.Cells(Rows.Count, 5).End(xlUp).Row To 2 Step -1 If Cells(i, 5) = "Kartonfarbe" Then Rows(i).Delete Next i Application.ScreenUpdating = True Exit Sub Err: MsgBox "Fehler in Sub" & Err.Number & ": " & Err.Description, vbCritical + vbOKOnly End Sub

Hallo Piet,
vielen Dank für deine Antwort. Du hast es völlig richtig verstanden. Meine Kenntnisse reichen in dem Fall leider nicht aus, um den Code entsprechend umzubauen.
Dein Code funktioniert leider nicht ganz so wie es soll. Aktuell wird aus der ersten Quelldatei die erste Zeile mit den Überschriften und dann erst wieder ab Zeile 3 Daten übertragen und aus der zweiten Quelldatei wieder die Überschriften und dann erst ab Zeile 4. So gehen die ersten Zeilen der zweiten Datei komplett verloren. Wie es bei mehr Dateien aussieht habe ich jetzt noch nicht getestet.
Meine Quelldateien Haben immer dieselbe Struktur. Im Tabellenblatt "Data" sind in den Spalten A bis AD, Daten und zum Teil auch Formeln enthalten. Die Anzahl der befüllten Zeilen kann je nach Quelldatei unterschiedlich sein. Zur Orientierung könnte die Spalte "P" verwendet werden. Hier stehen immer werte drin. wenn eine Zeile kopiert werden soll. Es sollen also nur die Zeilen Übertragen werden, bei denen in Spalte "P" ein Wert enthalten ist.
Die Zieldatei ist eine separate Exceldatei. Die Daten sollen als Werte, immer im Tabellenblatt "Bestellkonsolidierung" fortlaufend untereinander eingefügt werden.
Ich hoffe, dass ich die Infos verständlich erklären konnte.
Vielen Dank und viele Grüße
Alex

Public Sub DatenEinlesen() Dim oTargetSheet As Worksheet, oSourceBook As Workbook Dim sPfad As String, sDatei As String, loZeile As Long Dim loSpalte As Long, loZeileZiel As Long Application.ScreenUpdating = False Set oTargetSheet = ThisWorkbook.Sheets("Bestellkonsolidierung") sPfad = InputBox("Bitte Pfad eingeben", "Pfad") & "\" sDatei = Dir(CStr(sPfad & "*.xl*")) Do While sDatei "" Set oSourceBook = Workbooks.Open(sPfad & sDatei, False, True) With oSourceBook.Worksheets("Data") loZeile = .Cells(.Rows.Count, "B").End(xlUp).Row loSpalte = .Cells(1, .Columns.Count).End(xlToLeft).Column .Range(.Cells(2, 1), .Cells(loZeile, loSpalte)).Copy With oTargetSheet loZeileZiel = .Cells(.Rows.Count, 2).End(xlUp).Offset(1).Row .Cells(loZeileZiel, 1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats End With End With oSourceBook.Close False Loop With oTargetSheet loZeileZiel = .Cells(.Rows.Count, "B").End(xlUp).Row If WorksheetFunction.CountBlank(.Range("A1:A" & loZeileZiel)) > 0 Then .Range("A1:A" & loZeileZiel).SpecialCells(xlCellTypeBlanks).EntireRow.Delete End If End With Application.CutCopyMode = False Set oTargetSheet = Nothing: Set oSourceBook = Nothing End Sub

Public Sub DatenEinlesen() Dim oTargetSheet As Worksheet, oSourceBook As Workbook Dim sPfad As String, sDatei As String, loZeile As Long Dim loSpalte As Long, loZeileZiel As Long Application.ScreenUpdating = False Set oTargetSheet = ThisWorkbook.Sheets("Bestellkonsolidierung") sPfad = InputBox("Bitte Pfad eingeben", "Pfad") & "\" sDatei = Dir(CStr(sPfad & "*.xl*")) Do While sDatei "" Set oSourceBook = Workbooks.Open(sPfad & sDatei, False, True) With oSourceBook.Worksheets("Data") loZeile = .Cells(.Rows.Count, "B").End(xlUp).Row loSpalte = .Cells(1, .Columns.Count).End(xlToLeft).Column .Range(.Cells(2, 1), .Cells(loZeile, loSpalte)).Copy With oTargetSheet loZeileZiel = .Cells(.Rows.Count, 2).End(xlUp).Offset(1).Row .Cells(loZeileZiel, 1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats Application.CutCopyMode = False End With End With oSourceBook.Close False sDatei = Dir() Loop With oTargetSheet loZeileZiel = .Cells(.Rows.Count, "B").End(xlUp).Row If WorksheetFunction.CountBlank(.Range("A1:A" & loZeileZiel)) > 0 Then .Range("A1:A" & loZeileZiel).SpecialCells(xlCellTypeBlanks).EntireRow.Delete End If End With Application.CutCopyMode = False Set oTargetSheet = Nothing: Set oSourceBook = Nothing End Sub

Beliebteste Forumthreads (12 Monate)

13
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Auslesen mehrerer Exceldateien

13 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

13
Beiträge zum Forumthread

Beiträge zu diesem Forumthread