Tabellenblätter zusammenfassen und Kennzeichnen

Option Explicit

Sub Zusammenfassung_Aktualisiere_Klick()
' Uebertragen der Werte aus allen Blaettern einer Mappe eine Uebersicht  
' abhängig von der Menge der Daten - ein oder zwei Seiten  
'  
' Veraendertes Vorgehen:  
'               - Information ueber die Anzahl der in den Blaettern vorhandenen Saetze  
'               - die Saetze der Haelfte der Blaetter werden  
'                   auf je einem Blatt zusammengefasst  
'               - Es findet keine Zuschreibung statt - der Bereich auf dem ersten Blatt  
'                   wird vor Ausfuehrung des Makros geloescht, so dass nur noch die  
'                   Ueberschriften auf der Seite verbleiben  
'  
Dim Sh As Worksheet            ' Festlegung Arbeitsblatt  
Dim Wahlbool As Boolean     ' Variable zur Entscheidung der Aufteilung auf Blaetter  
Dim Uebersicht1 As String    ' Zweites Blatt fuer die Uebersicht  
Dim Wahl As String                ' Auswahlmoeglichkeit fuer Vorgehen bei nicht ausreichendem   
                              'Platz auf der Seite Uebersicht  
Dim BlattName As String      ' Variable zur Bestimmung des aufnehmenden Blattes  
Dim intRow As Long              ' Festlegung Zeilenanzahl fuer Uebergabe  
Dim intRowS As Long            ' genutzte Zeilenanzahl  
Dim j As Integer                      ' genutzte Zeilen in den Blaettern  
Dim jr As Long                        ' genutzte Spalten in den Blaettern  
Dim zaehler As Long             ' Anzahl der freien Zeilen  
Dim intsh As Integer              ' Blattzaehler fuer die Splittung aus zwei Uebersichtsblaetter  
Dim intAnz As Integer           ' Anzahl der in der Mappe vorhandenen Blaetter  
Dim Here As Variant
Dim MyColumn As Variant
Dim Jc As Long
'  
Const Fest = 2                  ' hier die Anzahl der "festen" Zeilen in jedem Blatt angeben;  
Const Fest1 = 2                 ' Wert der "festen" Zeilen auf der Uebersichtsseite  
Const Uebersicht = "Zusammenfassung"   ' hier den Namen der Uebersicht veraendern  
'  
'*** Beginn der Programmes - hier Ueberpruefung ***  
'  
' Bildschirmaktualisierung aus  
Application.ScreenUpdating = False
'  
' Festlegen der weiteren Angaben  
Uebersicht1 = Uebersicht & "1"      ' Vergabe des Namens fuer das zweite Blatt  
Wahlbool = False                    ' Generell erfolgt nur Zusammenfassung auf ein Blatt  
intsh = 0                           ' Zaehler fuer Zusammenfassung  
intAnz = Worksheets.Count           ' Anzahl der in Mappe vorhandenen Blaetter  
intAnz = Int(intAnz / 2)            ' Ganzzahliger Teil der Haelfte der Blaetter  
'  
' Fehlerkorrektur, wenn zweites Blatt fuer Uebersicht nicht existiert  
On Error GoTo Weiter
' Loeschen des zweiten Blattes der Uebersicht und Anzeige per MsgBox  
Application.DisplayAlerts = False
Sheets(Uebersicht & "1").Delete  
Application.DisplayAlerts = True
MsgBox "Blatt wurde geloescht!"     ' kann ausgelassen werden  
'  
' Sprungmarke fuer den Fall, dass zweites Blatt nicht existiert  
Weiter:
'  
' Abfangen durch eine Fehlerkorrektur, wenn Blattname nicht vorhanden  
On Error GoTo ErrorBlattName
'  
' Ueberpruefen des freien Raumes zum Kopieren  
' Schritt 1: Feststellen der Anzahl der Saetze  
For Each Sh In Sheets
    If Sh.Name <> Uebersicht Then
    Sh.Activate
    jr = Cells(Cells.Rows.Count, 1).End(xlUp).Row
    zaehler = zaehler + jr - Fest
    End If
Next
' Schritt 2: Freier Platz auf der Uebersicht  
Sheets(Uebersicht).Activate
intRowS = Cells(Cells.Rows.Count, 1).End(xlUp).Row
intRow = 65536 - intRowS - Fest1
'  
' Bei nicht ausreichendem Platz erfolgt Mitteilung und weitere Wahl durch User  
If zaehler > intRow Then
MsgBox "Das Zusammenfuehren der Datensaetze " & Chr(13) & _  
    "kann nicht auf einem Blatt erfolgen." & Chr(13) & _  
    Chr(13) & "In den zu kopierenden Blaettern befinden sich " & Chr(13) & _  
    "insgesamt " & zaehler & " Saetze." & Chr(13) & Chr(13) & _  
    "Verbleibende Zellen auf Uebersicht: " & intRow  

' Wahlmoeglichkeit des Users: Aufteilen oder Abbrechen  
Wahl = MsgBox("Sie haben die Wahl: " & Chr(13) & Chr(13) & _  
    "Wenn die Aufteilung auf zwei Seiten erfolgen soll: OK" & _  
    Chr(13) & "Wenn beendet werden soll: ABBRUCH", vbOKCancel)  
'Auswertung der Schaltflaechen  
    Select Case Wahl
        Case vbOK

    ' Einfuegen eines neuen Blattes, umbenennen und kopieren der Kopfangaben  
    ' Setzen der Variablen fuer das Kopieren auf zwei Blaetter  
            Sheets.Add after:=Sheets(Uebersicht)
            ActiveSheet.Name = Uebersicht & "1"  
            Sheets(Uebersicht).Activate
            Range("A1:CZ" & Fest1).Copy  
            Sheets(Uebersicht & "1").Activate  
            Range("a1").Select  
            Selection.PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False _
                , Transpose:=False
            Wahlbool = True
        Case vbCancel
    ' Abbruch auf Wunsch  
        MsgBox "Der Vorgang wird auf Ihren Wunsch beendet.", vbInformation  
        GoTo Beenden
    End Select
End If
'  
' Abfangen durch eine Fehlerkorrektur, wenn anderer Fehler  
On Error GoTo ErrorAndererFehler
'  
'*** Ab hier  beginnt die Verarbeitung ***  
'  
' Loeschen des Inhaltes auf dem Blatt Uebersicht  
' hier: Loeschen der Zeilen und Verschieben nach oben  
'  
Sheets(Uebersicht).Activate
' Sollten die Daten nicht in der zweiten Zeile beginnen,  
' ist die jeweilige Startzeile entsprechend zu veraendern  
Rows((Fest1 + 1) & ":" & intRowS).Delete Shift:=(xlUp)  
'  
For Each Sh In Sheets
    If Sh.Name <> Uebersicht Then
        If Sh.Name <> Uebersicht & "1" Then  
' Feststellen der genutzten Zeilen und Spalten  
' Feststellen der Adresse der letzten Spalte (Buchstabe)  
    intsh = intsh + 1
    If Wahlbool Then
        If intsh <= intAnz Then
        BlattName = Uebersicht
        Else
        BlattName = Uebersicht & "1"  
        End If
    Else
    BlattName = Uebersicht
    End If
    Sh.Activate
    jr = Cells(Cells.Rows.Count, 1).End(xlUp).Row
    Jc = ActiveSheet.UsedRange.Columns.Count            ' wenn Spalten geloescht werden,  
                                                        ' muss die Mappe entweder gespeichert  
                                                        ' werden oder analog zur Ermittlung  
                                                        ' der Zeilen vorgegangen werden  
    Here = Cells(1, Jc).Address
    MyColumn = Mid(Here, InStr(Here, "$") + 1, _  
    InStr(2, Here, "$") - 2)  
'  
' Kopie der beschriebenen Bereiche  
        Range("A" & Fest + 1 & ":" & MyColumn & jr).Select  
        Selection.Copy
'  
' Uebertragen der Daten und Einfügen ins Blatt Uebersicht nach Abhängigkeit  
        Sheets(BlattName).Select
' Feststellen des Einfügebereiches  
    intRowS = Cells(Cells.Rows.Count, 1).End(xlUp).Row
    If IsEmpty(Range("A1")) Then  
        intRow = 1
    Else
        intRow = intRowS + 1
    End If
        Range("A" & intRow).Select  
' Einfügen ins Blatt Uebersicht  
        ActiveSheet.Paste
        Range("A" & Fest1 + 1).Select  
        Sh.Activate
        Range("A" & Fest + 1).Select  
    End If
    End If
    Next
'  
'*** Normales Ende der Prozedur ***  
'  
Beenden:
    Sheets(Uebersicht).Activate
    Range("A" & Fest1 + 1).Select  
    Application.CutCopyMode = False
Application.ScreenUpdating = True
Exit Sub
'  
'*** Fehlerbehandlungen ***  
'  
'/// Falscher Blattname  
ErrorBlattName:
MsgBox "Fehler! Der Blattname existiert nicht!" & Chr(13) & _  
    Chr(13) & "Vorgang wird beendet.", vbCritical  
Range("A" & Fest1 + 1).Select  
GoTo Beenden
'  
'/// AndererFehler  
ErrorAndererFehler:
MsgBox "Fehler! Der Schreiber des Makros hat einen" & Chr(13) & _  
    "fatalen Denkfehler begangen!" & Chr(13) & Chr(13) & _  
    "Schreiben Sie ihm ihre Meinung!" & Chr(13) & _  
    Chr(13) & "Der Vorgang wird beendet.", vbExclamation  
Range("A" & Fest1 + 1).Select  
GoTo Beenden

End Sub