Option Explicit
' ****************************************************************
' Autor/en und Original-Quelltext unter:
' https://www.online-vba.de/vba_datensammeln2.php
' Verwendung der Quelltexte auf eigene Gefahr!
' Es gelten die Nutzungsbedingungen von https://www.online-vba.de
' ****************************************************************
Public Sub OVBAde_DatenAusMehrerenSheets()
Dim oTargetSheet As Object
Dim oSheet As Object
Dim lErgebnisZeile As Long
Dim i As Long
Application.ScreenUpdating = False 'Das "Flackern" ausstellen
'Schritt 1: Neues Arbeitsblatt für die Ergebnisse erstellen
Set oTargetSheet = ActiveWorkbook.Sheets.Add
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
'Blattnamen in Spalte 1 eintragen
oTargetSheet.Cells(lErgebnisZeile, 1).Value = CStr(oSheet.Name)
'Eigentliche Datenübertragung - Als Beispiel die Zellen A1 bis A10
For i = 1 To 10
oTargetSheet.Cells(lErgebnisZeile, i + 1).Value = _
oSheet.Cells(1, i).Value
Next i
'Schritt 4: Nächste Zeile in der Ergebnistabelle und nächstes Arbeitsblatt
lErgebnisZeile = lErgebnisZeile + 1 'nächste Zeile auf dem Ergebnisblatt
End If
Next oSheet
Application.ScreenUpdating = True 'Das Bildschirm-Aktualisieren wieder einschalten
'Variablen aufräumen
Set oTargetSheet = Nothing
Set oSheet = Nothing
End Sub