Tabellenblätter zusammenfassen (kopieren)

Einzelne Tabellenblätter in einem Blatt nahtlos untereinander kopieren

Gegeben ist eine Arbeitsmappe mit mehreren Tabellenblättern. Als Beispiel verwende ich die in meinen Schulungen lieb gewonnene Bäckerei Kleinbrot. In dieser Mappe sind 12 Arbeitsblätter (Register), welche jeweils den entsprechenden Monatsnamen haben. Weiterhin ist ein Blatt enthalten, wo die Feiertage des entsprechenden Jahres aufgelistet sind. Die Monats-Blätter sind alle identisch aufgebaut, die Anzahl der Zeilen ist dem entsprechenden Monat angepasst.

Diese 12 Blätter sollen nun in der aktuellen Mappe in einem neuen Blatt zusammengefasst werden. Es soll nicht konsolidiert (alle Zahlen addiert) werden, da die einzelnen Werte nach wie vor im Zugriff für Auswertungen in einer PivotTable vorhanden sein sollen. Das Register Feiertage soll naturgemäß nicht in die Zusammenfassung integriert werden, diese Daten haben in dieser Aufgabe keine Bedeutung.

Natürlich lassen sich die wenigen Blätter von Hand untereinander kopieren. Aber weniger schön wird es dann, wenn beispielsweise erst die Daten des ersten halben Jahres eingegeben worden sind und Monat für Monat die gleiche Prozedur des Kopierens erfolgen muss. Und noch unangenehmer ist es gewiss dann, wenn in einem früheren Monat eine Änderung gebucht worden ist. Das kann durchaus einmal eine Zeile weniger oder mehr sein (zugegeben, nicht in solch einer Monatsaufstellung) oder eine Änderung des Betrages. Dann ist „Fummelarbeit“ angesagt. Darum sollte so etwas von einem Makro erledigt werden.

Prinzipiell läuft das Makro so ab:

  • Ein neues Blatt mit dem Namen Zusammenfassung anlegen.
  • Die erste Zeile Datum bis Sonstiges kopieren …
  • … und in A1:G1 der Zusammenfassung als Wert mit Zahlenformat einfügen (damit eventuelle andere Formatierungen nicht mit übernommen werden).
  • Beginnend mit Januar und endend mit Dezember jeweils A2:Gnn kopieren und an das Ende der vorhandenen Daten im Blatt Zusammenfassung gleichermaßen anfügen. Das nn in der Kopier-Adresse bezieht sich auf die Zeile mit dem Monatsletzten, der ja von Monat zu Monat unterschiedlich ist.

Vielleicht fragen Sie sich jetzt, warum die jeweiligen Summen-Felder nicht mit kopiert werden. Das hängt mit dem Prinzip zusammen, dass so wenig wie möglich Redundanzen (mehrfach vorkommende Werte) geschaffen werden sollten. Die Zusammenfassung wird die Grundlage für eine PivotTable sein, und dort kann dann nach Herzenslust ohne den Ballast vorgefertigter Ergebnisse ausgewertet werden.

Die erste Version des Codes ist weitgehend universell gehalten, damit eine Anpassung für andere Datenstrukturen leichter möglich ist. Eine kleine Änderung wird wegen der „Intelligenz“ des Excel in Sachen Reihenfolge der Monate noch folgen. Hier nun erst einmal der Basis-Code:

Option Explicit

Sub BlaetterZusammenfassen()
   Dim wks As Worksheet, wksZiel As Worksheet, Blatt As Long, AnzBlaetter As Long
   Dim Ziel As String, lRowS As Long, lRowD As Long
   
   Application.ScreenUpdating = False
   Ziel = "Zusammenfassung"
   If Not BlattExistiert(Ziel) Then
   AnzBlaetter = Sheets.Count
      Sheets.Add After:=Sheets(AnzBlaetter)
      ActiveSheet.Name = Ziel
   End If
   Set wksZiel = Sheets(Ziel)
   Sheets("Januar").Range("A1:G1").Copy
   wksZiel.Range("A1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats   'Falls Zahlen in der Überschrift sind
   AnzBlaetter = Sheets.Count
   For Blatt = 1 To AnzBlaetter
      If Sheets(Blatt).Name <> Ziel And Sheets(Blatt).Name <> "Feiertage" Then
         lRowS = lRow(Sheets(Blatt))
         lRowD = lRow(wksZiel)
         Sheets(Blatt).Range("A2:G" & lRowS - 1).Copy
         wksZiel.Range("A" & lRowD + 1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
      End If
   Next Blatt
   Application.CutCopyMode = False
   wksZiel.Columns(1).AutoFit
   Range("A1").Select   'Ausnahsweise :-)
End Sub

'Wks auf Existenz prüfen
Function BlattExistiert(BlattName) As Boolean
   Dim x As Variant, EN As Variant
   On Error GoTo ErrorHandler
   x = Sheets(BlattName).Cells(1, 1)
   BlattExistiert = True
   Exit Function

ErrorHandler:
   BlattExistiert = False
End Function

Function lRow(wks As Worksheet) As Long
   lRow = wks.Cells(Rows.Count, 1).End(xlUp).Row
End Function

Dieser Code läuft einwandfrei und kann auch von Einsteigern mit grundlegenden Vorkenntnissen in Sachen VBA auf eine andere Datenstruktur angepasst werden.

▲ nach oben …

Speziell für diese Aufgabe, wo alle Monate eines Jahres ausgewertet werden sollen, bietet sich folgende Änderung des Codes an:

Sub BlaetterZusammenfassen2()
   Dim wks As Worksheet, wksZiel As Worksheet, AnzBlaetter As Long
   Dim Ziel As String, lRowS As Long, lRowD As Long
   Dim aMonat(12), Monat As String, i As Long
   
   Application.ScreenUpdating = False
   Ziel = "Zusammenfassung"
   If Not BlattExistiert(Ziel) Then
   AnzBlaetter = Sheets.Count
      Sheets.Add After:=Sheets(AnzBlaetter)
      ActiveSheet.Name = Ziel
   End If
   Set wksZiel = Sheets(Ziel)
   For i = 1 To 12
      aMonat(i) = Format(DateSerial(2000, i, 1), "MMMM")
   Next i
   
   Sheets(aMonat(1)).Range("A1:G1").Copy
   wksZiel.Range("A1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats   'Falls Zahlen in der Überschrift sind
   For i = 1 To 12
      Set wks = Sheets(aMonat(i))
      lRowS = lRow(wks)
      lRowD = lRow(wksZiel)
      wks.Range("A2:G" & lRowS - 1).Copy
      wksZiel.Range("A" & lRowD + 1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
   Next i
   Application.CutCopyMode = False
   wksZiel.Columns(1).AutoFit
   Range("A1").Select   'Ausnahsweise :-)
End Sub

Die erste Änderung ist im Kopfbereich zu sehen. Unterhalb Option Explicit ist die Zeile

Option Base 1

eingefügt. Das bewirkt, dass alle Arrays 1-basiert sind, immer mit Element (Index) 1 beginnen und nicht mit 0. Auch wenn manche „Informatiker“ das süffisant als „Fraueneschalter“ bezeichnen, hat das seine Vorteile. Ich muss nicht ewig umdenken, denn manche Arrays in Excel-VBA fangen von Haus aus mit 1 an.

Die restlichen Änderungen erkennen Sie selber, wenn Sie die wenigen Zeilen vergleichen. Neue Variablen sind hinzugekommen, andere wurden gelöscht. Die eigentliche Neuerung ist, dass ein Array mit den Monatsnamen (übrigens landestypisch und in den Landeseinstellungen des Systems) erstellt und dann nacheinander direkt auf das jeweilige Blatt zugegriffen wurde.

▲ nach oben …

Was noch prinzipiell verbessert bzw. verändert werden könnte, basierend auf dem ersten Code:

  1. Wenn bei Aufruf des Makros das Blatt Zusammenfassung existiert, dann soll dieses entweder komplett gelöscht oder nur der Inhalt geleert werden.
  2. Tage ohne Umsatz sollen nicht übernommen bzw. eliminiert werden.
  3. Nur wenige benannte von vielen Tabellenblättern sollen kopiert werden.

Zum ersten Punkt: Das ist gewiss immer dann wichtig, wenn diese Sub monatlich aufgerufen wird. Da hier zu Beginn immer alle Monate an die vorhandenen Daten angefügt werden, gibt das einen Daten-Wirrwarr, der so nicht korrekt ausgewertet werden kann. Hier ein geänderter Code-Ausschnitt, um die Daten zu löschen:

If Not BlattExistiert(Ziel) Then
   AnzBlaetter = Sheets.Count
   Sheets.Add After:=Sheets(AnzBlaetter)
   ActiveSheet.Name = Ziel
Else
   Sheets(Ziel).Cells.ClearContents
End If

Das Blatt vorher zu löschen ist prinzipiell nicht erforderlich. Falls Sie dennoch Wert darauf legen, zeichnen Sie den Code einfach auf, passen die BlattExistiert-Prüfung an und integrieren ihn an passender Stelle.

Den zweiten Punkt können Sie am einfachsten lösen, indem Sie einen kleinen Umweg gehen …

  • Kopieren Sie erst alle Daten, wie gehabt.
  • Machen Sie aus den Daten in Zusammenfassung eine Liste, eine Intelligente Tabelle; beispielsweise mit StrgT oder StrgL.
  • Tragen Sie in H1 eine Überschrift ein, beispielsweise Umsatz.
  • Fügen Sie in H2 diese Formel ein: =SUMME(B2:G2)>0. Wenn Sie auf die Felder B2 und G2 klicken, dann werden die Feldnamen der Liste automatisch übernommen; das ist auch OK. Alle Zeilen enthalten nun einen WAHR/FALSCH-Wert.
  • Filtern Sie Spalte H nun nach FALSCH und löschen die entsprechenden angezeigten Zeilen (natürlich nicht die Überschrift).
  • Anschließend können Sie die „Hilfsspalte“ wieder löschen.

Der dritte Punkt bedeutet wiederum eine andere Programmierung. Die Basisdaten sind die gleichen, der Einfachheit halber aber sollen nur die ersten drei Monate kopiert werden. Und es wird davon ausgegangen, dass die Arbeitsblätter / Register auch tatsächlich in der aktuellen Mappe existieren (das erspart eine immer wiederkehrende Überprüfung).

Sub BlaetterZusammenfassen3()
   Dim wks As Worksheet, wksZiel As Worksheet, Blatt As Long, AnzBlaetter As Long
   Dim Ziel As String, lRowS As Long, lRowD As Long
   
   Application.ScreenUpdating = False
   Ziel = "Zusammenfassung"
   If Not BlattExistiert(Ziel) Then
      AnzBlaetter = Sheets.Count
      Sheets.Add After:=Sheets(AnzBlaetter)
      ActiveSheet.Name = Ziel
   Else
      Sheets(Ziel).Cells.ClearContents
   End If
   Set wksZiel = Sheets(Ziel)
   
   For Each wks In ThisWorkbook.Sheets
      Select Case wks.Name
      Case "Januar", "februar", "März"
         lRowS = lRow(wks)
         lRowD = lRow(wksZiel)
         wks.Range("A2:G" & lRowS - 1).Copy
         wksZiel.Range("A" & lRowD + 1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
      End Select
   Next wks
   Application.CutCopyMode = False
   wksZiel.Columns(1).AutoFit
   Range("A1").Select   'Ausnahsweise :-)
End Sub

Und ja, es ist ein Fehler im Code. Denn Sie werden beim Ausführen rasch feststellen, dass nur zwei Monate kopiert worden sind. Und das hat nichts damit zu tun, dass es beides Monate mit 31 Tagen sind oder der Februar die Sonderstellung mit den 28/29 Tagen hat. Die Ursache ist einfach gemein 😉 . Im Code ist der Monatsname klein geschrieben und im Register ist das erste Zeichen natürlich groß. Aber VBA nimmt es mit der Groß- Kleinschreibung wesentlich genauer als Excel selbst. Ändern Sie den „februar“ auf „Februar“ und alles wird seinen korrekten Weg gehen. – Natürlich lässt sich eine derartige Selektion auch mit beliebigen anderen Blattnamen bewerkstelligen.

In neueren Excel-Versionen (Windows), ab Excel 2010, lässt sich solch ein Problem auch sehr elegant mit einem Add-In Power Query lösen. In der 2016er-Version (auch nur Windows) ist dieses Werkzeug schon integriert.

▲ nach oben …

Dieser Beitrag wurde unter Mit VBA/Makro, Musterlösungen, Tabelle und Zelle abgelegt und mit , , , , , , verschlagwortet. Setze ein Lesezeichen auf den Permalink.