Sollen die Daten mehrerer Tabellenblätter gleichen Aufbaus auf einer Übersichtsseite untereinander konsolidiert werden, so geht dies mit folgendem Code. Es wird davon ausgegangen, dass jedes Tabellenblatt eine Überschrift in Zeile 1 hat.

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

 

Code für ein allgemeines Modul

 

 

 

Sub Konsolidieren()

'Code für ein allgemeines Modul

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

'Autor: Jürgen Hennekes

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

'Die Tabellenblätter haben eine Überschrift in Zeile 1, 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 "Konsolidierung" wird, wenn nicht bereits vorhanden, ganz links erstellt.

Dim wks As Worksheet      'Tabelle Konsolidierung

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

Dim intLastS As Integer   'Letzte benutzte Spalte in den Tabellen

Dim bln As Boolean

 

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

For intSh = 1 To ActiveWorkbook.Worksheets.Count

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

Set wks = Worksheets("Konsolidierung")

  bln = True

  Exit For

End If

Next

 

'Falls nicht vorhanden dann erstellen

If bln = False Then

Set wks = Worksheets.Add

wks.Name = "Konsolidierung"

End If

 

'Blatt Konsolidierung nach links schieben

wks.Move Before:=Sheets(1)

 

'Daten auf Blatt "Konsolidierung" 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 Konsolidierung ü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

 

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