Sollen die Daten mehrerer Tabellenblätter gleichen Aufbaus innerhalb einer Datei auf einer Übersichtsseite zusammengeführt werden, so geht dies mit folgendem Code. Es wird davon ausgegangen, dass jedes Tabellenblatt eine Überschrift in Zeile 1 ab A1 besitzt.

Wenn nicht bereits vorhanden, wird ein neues Tabellenblatt links mit dem Namen "AlleDaten" erstellt.

 

Code für ein allgemeines Modul

 

Sub AlleDaten()

'Code für ein allgemeines Modul

'*********************************

'Autor: Jürgen Hennekes

'*********************************

'Es werden die Daten aller Tabellenblätter innerhalb einer Datei auf einem neuen Tabellenblatt gelistet.

'Die Tabellenblätter haben eine Überschrift in Zeile 1 ab A1, die Daten stehen ab Zeile 2

'Die Tabellenblätter haben einen identischen Aufbau ( Anzahl Spalten ). Die Anzahl der Zeilen spielt keine Rolle.

'Ein Tabellenblatt mit dem Namen "AlleDaten" wird, wenn nicht bereits vorhanden, ganz links erstellt.

Dim wks As Worksheet      'Tabelle AlleDaten

Dim intSh As Integer      'Zähler für Tabelle1 bis TabelleX

Dim intLastS As Integer   'Letzte benutzte Spalte in den Tabellen

Dim bln As Boolean

'Prüfung ob Blatt "AlleDaten" bereits vorhanden ist.

For intSh = 1 To ActiveWorkbook.Worksheets.Count

  If Worksheets(intSh).Name = "AlleDaten" Then

    Set wks = Worksheets("AlleDaten")

    bln = True

    Exit For

  End If

Next

'Falls nicht vorhanden dann erstellen

If bln = False Then

  Set wks = Worksheets.Add

  wks.Name = "AlleDaten"

End If

'Blatt AlleDaten nach links schieben

wks.Move Before:=Sheets(1)

'Daten auf Blatt "AlleDaten" löschen und die Überschrift aus Tabelle1 holen

'Anzahl der Spalten zählen. Gilt dann für alle Blätter da Aufbau identisch sein muss

wks.Cells.ClearContents

Worksheets(2).Rows(1).Copy Destination:=wks.Range("A1")

intLastS = wks.Cells(1, Columns.Count).End(xlToLeft).Column

'Daten aus allen Tabellen nach Tabelle "AlleDaten" übertragen

For intSh = 2 To ActiveWorkbook.Worksheets.Count

  With Worksheets(intSh)

   .Range(.Cells(2, 1), .Cells(fncLastRow(intSh, intLastS), intLastS)).Copy

   wks.Cells(wks.UsedRange.Rows.Count, 1).Offset(1, 0).PasteSpecial Paste:=xlValues

  End With

Next

Application.CutCopyMode = False

MsgBox "Die Daten aus " & intSh - 2 & " Tabellenblättern wurden gelistet.", 64

End Sub

Public Function fncLastRow(ByVal intSh As Integer, intLastS As Integer) As Long

Dim intS As Integer

With Worksheets(intSh)

  For intS = 1 To intLastS

   If .Cells(Rows.Count, intS).End(xlUp).Row > fncLastRow Then

     fncLastRow = .Cells(Rows.Count, intS).End(xlUp).Row

   End If

  Next

End With

End Function

 

 

 

 

 

 

 

Im nachfolgenden Code werden zusätzlich die Tabellenblattnamen in Spalte A gelistet.

Von Vorteil, soll eine Auswertung per Pivottabelle erfolgen und die Datenquelle einfließen.

 

 

Sub AlleDaten2()

'Code für ein allgemeines Modul

'*********************************

'Autor: Jürgen Hennekes

'*********************************

'Es werden die Daten aller Tabellenblätter innerhalb einer Datei auf einem neuen Tabellenblatt gelistet.

'In Spalte A wird das Quellblatt gelistet.

'Die Tabellenblätter haben eine Überschrift in Zeile 1 ab A1, die Daten stehen ab Zeile 2

'Die Tabellenblätter haben einen identischen Aufbau ( Anzahl Spalten ). Die Anzahl der Zeilen spielt keine Rolle.

'Ein Tabellenblatt mit dem Namen "AlleDaten" wird, wenn nicht bereits vorhanden, ganz links erstellt.

Dim wks As Worksheet      'Tabelle AlleDaten

Dim intSh As Integer      'Zähler für Tabelle1 bis TabelleX

Dim intLastS As Integer   'Letzte benutzte Spalte in den Tabellen

Dim lngCopyRows As Long   'Anzahl kopierte Zeilen

Dim bln As Boolean

'Prüfung ob Blatt "AlleDaten" bereits vorhanden ist.

For intSh = 1 To ActiveWorkbook.Worksheets.Count

  If Worksheets(intSh).Name = "AlleDaten" Then

    Set wks = Worksheets("AlleDaten")

    bln = True

    Exit For

  End If

Next

'Falls nicht vorhanden dann erstellen

If bln = False Then

  Set wks = Worksheets.Add

  wks.Name = "AlleDaten"

End If

'Blatt AlleDaten nach links schieben

wks.Move Before:=Sheets(1)

'Daten auf Blatt "AlleDaten" löschen und die Überschrift aus Tabelle1 holen

'Anzahl der Spalten zählen. Gilt dann für alle Blätter da Aufbau identisch sein muss

wks.Cells.ClearContents

wks.Range("A1").Value = "Tabellenname"

Worksheets(2).Range("A1:IU1").Copy Destination:=wks.Range("B1")

intLastS = wks.Cells(1, Columns.Count).End(xlToLeft).Column

'Daten aus allen Tabellen nach Tabelle "AlleDaten" übertragen

For intSh = 2 To ActiveWorkbook.Worksheets.Count

  With Worksheets(intSh)

    .Range(.Cells(2, 1), .Cells(fncLastRow(intSh, intLastS), intLastS)).Copy

    wks.Cells(wks.UsedRange.Rows.Count, 2).Offset(1, 0).PasteSpecial Paste:=xlValues

    lngCopyRows = wks.UsedRange.Rows.Count - Cells(Rows.Count, 1).End(xlUp).Row

    wks.Range("A" & wks.Cells(Rows.Count, 1).End(xlUp).Row + 1).Resize(lngCopyRows) = Worksheets(intSh).Name

  End With

Next

Application.CutCopyMode = False

MsgBox "Die Daten aus " & intSh - 2 & " Tabellenblättern wurden gelistet.", 64

End Sub

Public Function fncLastRow(ByVal intSh As Integer, intLastS As Integer) As Long

Dim intS As Integer

With Worksheets(intSh)

  For intS = 1 To intLastS

   If .Cells(Rows.Count, intS).End(xlUp).Row > fncLastRow Then

     fncLastRow = .Cells(Rows.Count, intS).End(xlUp).Row

   End If

  Next

End With

End Function