CODE-SCHNIPSEL

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

Public Sub OVBAde_DatenTabellenAusMehrerenSheetsEinsammeln)
  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