Hallo Zusammen,

ich benötige Hilfe bei einer Makro. Ich habe einen Ordner mit mehreren Excel Dateien, die jeweils mehrere Tabellenblätter mit der selben Struktur beinhalten. Die Makro sollte alle Tabellenblätter von allen Dateien in eine neue Datei oder Tabellenblatt untereinander kopieren.

Ich habe einen Code gefunden, der mir alle Tabellenblätter aus der geöffneten Excel Datei kopiert und in ein neues Tabellenblatt "Konsoliederung" einfügt. Nun bräuchte ich, dass noch die anderen Tabs aus den Dateien in dem Ordner eingefügt werden.

Ich habe mir schon einzelne Codes und videos angeschaut aber ich bekomme das nicht hin mit der Schleife, bzw. aus 2 Codes einen zu machen.

Das hier wäre der Code:

Sub Konsolidieren2()
'Konsolidierung ohne Überschriften ( Zeile 1 )
'In Spalte A wird der Name der Herkunfttabelle gelistet
Dim Wks As Worksheet
Dim Bereich As Range
Dim strLC As String
Dim i As Integer
Dim lngA As Long
Dim lngE As Long

Set Wks = Worksheets.Add
Wks.Name = "Konsolidierung"

For i = 2 To Worksheets.Count
 With Worksheets(i).UsedRange
  strLC = .Cells(.Rows.Count, .Columns.Count).Address
  Set Bereich = .Range("A2:" & strLC)
  lngA = Wks.Cells(Rows.Count, 1).End(xlUp).Row + 1
  lngE = Bereich.Rows.Count
  Wks.Range("A" & lngA & ":A" & (lngE + lngA - 1)) = Worksheets(i).Name
  Bereich.Copy Destination:= _
  Wks.Cells(Rows.Count, 2).End(xlUp).Offset(1, 0)
 End With
Next i
End Sub

Und hier wäre mein Versuch, der allerdings nicht funktioniert:

ub MWSheetsAusMehrerenDateienEinlesen()
   Dim oTargetBook As Object
   Dim oSourceBook As Object
   Dim sPfad As String
   Dim sDatei As String
    
     Application.ScreenUpdating = False 'Das "Flackern" ausstellen
     Application.DisplayAlerts = False 'Keine Fehlermeldungen anzeigen
    
     'Schritt 1: Arbeitsmappe festlegen, in die die neuen Sheets eingefügt werden...
     Set oTargetBook = ActiveWorkbook
    
     'Wichtiger Hinweis: Die Arbeitsblätter dürfen nicht vorhanden sein!
     'Alternativer Umbau: Löschen evtl. bereits vorhandener Arbeitsblätter
    
     'Schritt 2: Schleife über alle Excel Dateien in einem Verzeichnis
     sPfad = "C:\Users\LIL1BE\Desktop\TEST MAKRO KST"
     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
        
         'Es wird immer das erste Tabellenblatt Sheets(1) kopiert!
         oSourceBook.Sheets(1).Copy after:=oTargetBook.Sheets(oTargetBook.Sheets.Count)
        
         'Es wird versucht den Dateinamen als Arbeitsblattnamen zu setzen.
         'Ist dieser bereits vorhanden wird der Fehler abgefangen und das neue Blatt
         'bekommt keinen anderen Namen und behält den typischen Namen Tabelle x
         On Error Resume Next
        
         'Arbeitsblattname wird der Dateiname
         oTargetBook.Sheets(oTargetBook.Sheets.Count).Name = sDatei
        
         'Wenn ein Fehler aufgetreten ist, wird dieser resettet
         If Err.Number <> 0 Then
             Err.Number = 0
             Err.Clear
         End If
         On Error GoTo 0
        
         '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
     Application.DisplayAlerts = True 'Fehlermeldungen wieder anzeigen
    
     'Kleine finale Fertig-Meldung
     MsgBox "Fertig!", vbInformation + vbOKOnly, "Hinweis!"
    
     'Variablen aufräumen
     Set oTargetBook = Nothing
     Set oSourceBook = Nothing
End Sub
 

Ich wäre für jede Hilfe sehr danbar.

Viele Grüße,

Albert