Option Explicit
'Makro zum Zusammenfassen aller Blätter der aktiven Arbeitsmappe auf einem
'neuen Blatt->Zusammenfassung'
'Voraussetzung: Alle Blätter haben die gleiche Spaltenstruktur Bedeutung/Format
'
'<<< A N P A S S E N >>>
'ZeileNr vor der erster Zeile mit zu übertragenden Werten, hier also eine Überschriftenzeile
Private Const cZ_ZeileVorErsterWerteZeile = 1
'Name des Zusammenfassungs-Blattes
Private Const cBLT_NAME_ZUS = Zusammenfassung
'<<< A N P A S S E N E N D E >>>
Sub AlleBlaetterZusammenfassen()
Dim wb As Workbook, ws As Worksheet, wsz As Worksheet
Dim lRows As Long, lCols As Long, z As Long
Set wb = ActiveWorkbook
->pruefen, ob es schon ein Blatt->Zusammenfassung' gibt
On Error Resume Next
Set ws = wb.Worksheets(cBLT_NAME_ZUS)
On Error GoTo 0
If Not ws Is Nothing Then
MsgBox ein Blatt nit Namen & cBLT_NAME_ZUS & ist bereits vorhanden.
GoTo AUFRAEUMEN
End If
->erstes Blatt als Grundlage für Zusammenfassung kopieren
Set ws = wb.Worksheets(1)
ws.Copy Before:=ws
->Zusammenfassungsblatt setzen
Set wsz = wb.Worksheets(1)
wsz.Name = cBLT_NAME_ZUS
->Über alle Blätter
z = cZ_ZeileVorErsterWerteZeile
For Each ws In wb.Worksheets
If ws.Name <> cBLT_NAME_ZUS Then
Call LetzteZeileSpalteBestimmen(ws, lCols, lRows)
If lRows > cZ_ZeileVorErsterWerteZeile Then
ws.Range( _
ws.Cells(cZ_ZeileVorErsterWerteZeile + 1, 1), _
ws.Cells(lRows, lCols) _
).Copy
z = z + 1
wsz.Range(wsz.Cells(z, 1), wsz.Cells(z, 1)).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
z = z + lRows - cZ_ZeileVorErsterWerteZeile - 1
End If
End If
Next
AUFRAEUMEN:
Set wb = Nothing: Set ws = Nothing: Set wsz = Nothing
End Sub
Function LetzteZeileSpalteBestimmen(ws As Worksheet, lCols As Long, lRows As Long)
Dim lZeile As Long, lSpalte As Long, bLeer As Boolean
lCols = ws.UsedRange.Column + ws.UsedRange.Columns.Count - 1
lRows = 0
For lSpalte = 1 To lCols
lZeile = ws.Cells(ws.Rows.Count, lSpalte).End(xlUp).Row
If lRows < lZeile Then lRows = lZeile
Next
If lRows = 1 Then
->zusätzlich die erste Zeile auf Inhalt überprüfen,
bLeer = True
For lSpalte = 1 To lCols
If ws.Cells(1, lSpalte).Value <> Then bLeer = False: Exit For
Next
If bLeer Then lRows = 0
End If
End Function
