Option Explicit
' ************************************************************************************************
' Autor/en: http://www.online-vba.de - Marc Wershoven
' Verwendung der Quelltexte auf eigene Gefahr!
' Es gelten die Nutzungsbedingungen von www.online-vba.de!
' Original-Quelltext: www.online-vba.de/vba_datensammeln7.php
' ************************************************************************************************

Sub MWDatenTabellenAusMehrerenSheetsEinsammeln)
   Dim oTargetSheet As Object
   Dim oSheet As Object
   Dim lErgebnisZeile As Long
   Dim i As Long
   Dim z As Long
   Dim s As Long
    
     Application.ScreenUpdating = False 'Das "Flackern" ausstellen
    
     'Schritt 1: Neues Arbeitsblatt für die Ergebnisse erstellen
     Set oTargetSheet = ActiveWorkbook.Sheets.Add
    
     'Alternativ Zuweisung eines bereits vorhandenen Blattes mit vorherigem Löschen
     'Set oTargetSheet = ActiveWorkbook.Sheets("VorhandenesBlatt")
     'oTargetSheet.Cells.ClearContents 'Nur Inhalte löschen
    
     lErgebnisZeile = 2 'Ergebnisse eintragen ab Zeile 2
    
     'Schritt 2: Schleife über alle Sheets
     For Each oSheet In ActiveWorkbook.Sheets
    
         'Schritt 3: Datenübertragung nur wenn nicht das neue Blatt vorliegt
         If oSheet.Name <> oTargetSheet.Name Then
        
             'Wenn die Ergebniszeile 2 ist nehmen wir noch einmalig die Tabellenüberschriften mit
             If lErgebnisZeile = 2 Then
                 oTargetSheet.Cells(1, 1).Value = "Quellblatt"
                 For i = 1 To 10 'überschriften der Spalten 1 bis 10 übertragen
                     oTargetSheet.Cells(1, i + 1).Value = oSheet.Cells(1, i).Value
                 Next i
             End If
            
             'Eigentliche Datenübertragung - Alle Zeilen der Sheets ab Zeile 2 bis Tabellenende
             For z = 2 To oSheet.UsedRange.Rows.Count
                 'Blattnamen in Spalte 1 eintragen
                 oTargetSheet.Cells(lErgebnisZeile, 1).Value = CStr(oSheet.Name)
                 For s = 1 To 10 'Spalten 1 bis 10 übertragen
                     oTargetSheet.Cells(lErgebnisZeile, s + 1).Value = oSheet.Cells(z, s).Value
                 Next s
                 lErgebnisZeile = lErgebnisZeile + 1 'nächste Zeile auf dem Ergebnisblatt
             Next z
            
         End If
        
     Next oSheet 'nächstes Arbeitsblatt
    
     Application.ScreenUpdating = True 'Das Bildschirm-Aktualisieren wieder einschalten
    
     'Variablen aufräumen
     Set oTargetSheet = Nothing
     Set oSheet = Nothing
End Sub