Aus ca. 100 Tabellenblättern ohne Datenverlust 1 erstellen

Option Explicit
'Definitionen zum Aufbau eines Quell-Tabellenblattes
Const c_SP_ArtNr As Long = 1
Const c_SP_Gruppe As Long = 2
Const c_SP_Baureihe As Long = 3
Const c_SP_Beschr As Long = 4
Const c_ZQ_UebSchr As Long = 2
Const c_ZQ_ErsteWerteZeile As Long = c_ZQ_UebSchr + 1
'abweichende Definitionen für Zusammenfassungsblatt
Const c_TabName_Zusammenfassung As String = Zusammenfassung
Const c_ZZ_UebSchr As Long = 1
'********************************************************
Public Sub ModellbahnTabsZusammenfuehren()
  
  Dim wb As Workbook, ws As Worksheet, wsz As Worksheet
  Dim l_zus_Zeile As Long, l_ws_cnt As Long
 
  Set wb = ActiveWorkbook
  Set ws = wb.Worksheets(1)
 ->Zusammenfassungsblatt einfügen
  wb.Worksheets.Add Before:=ws
  Set wsz = ActiveSheet
  wsz.Name = c_TabName_Zusammenfassung
  l_zus_Zeile = ZusammenfassungFormatieren(ws, wsz)
 ->Bildschirm-Update abschalten
  Application.ScreenUpdating = False
 ->Über alle Blätter
  l_ws_cnt = 0
  For Each ws In wb.Worksheets
   ->nicht Zusammenfassungsblatt
    If ws.Name <> c_TabName_Zusammenfassung Then
      l_ws_cnt = l_ws_cnt + 1
      Application.StatusBar = _
        Bearbeite Blatt  & l_ws_cnt &  von  & wb.Worksheets.Count
      If Not NaechsteBlattInZusammenfassungUebertragen(ws, wsz, l_zus_Zeile) Then
        MsgBox (max. Zeileanzahl der Zieltabelle ist erreicht.)
        Exit For
      End If
    End If
  Next
  Application.StatusBar = 
 ->Bildschirm-Update anschalten
  Application.ScreenUpdating = True
  MsgBox (In der Zusammenfassung sind  & _
          (l_zus_Zeile - c_ZZ_UebSchr) &  Artikel enthalten.)
  Set wb = Nothing: Set ws = Nothing: Set wsz = Nothing
End Sub
'********************************************************
Function NaechsteBlattInZusammenfassungUebertragen( _
    ws As Worksheet, wsz As Worksheet, l_zus_Zeile As Long) As Boolean
  Dim l_rows As Long, z As Long, l_Bemerkung_Zeile As Long
  Dim s_Beschr As String, s_Baureihe As String
  
  NaechsteBlattInZusammenfassungUebertragen = True
  
 ->letzte Zeile über Spalte Bemerkung definieren
  l_rows = ws.Cells(ws.Rows.Count, c_SP_Beschr).End(xlUp).Row
  
  For z = c_ZQ_ErsteWerteZeile To l_rows
   ->neuer Artikel
    If ws.Cells(z, c_SP_ArtNr).Value <>  Then
     ->naechste freie Zeile in Zusammenfassung
      l_zus_Zeile = l_zus_Zeile + 1
     ->Zieltabelle voll ?
      If l_zus_Zeile > 65535 Then
       ->Fehlerkennung setzen + Schluß
        NaechsteBlattInZusammenfassungUebertragen = False
        Exit Function
      End If
      wsz.Cells(l_zus_Zeile, c_SP_ArtNr).Value = ws.Cells(z, c_SP_ArtNr).Value
      wsz.Cells(l_zus_Zeile, c_SP_Gruppe).Value = ws.Cells(z, c_SP_Gruppe).Value
      wsz.Cells(l_zus_Zeile, c_SP_Baureihe).Value = ws.Cells(z, c_SP_Baureihe).Value
      wsz.Cells(l_zus_Zeile, c_SP_Beschr).Value = ws.Cells(z, c_SP_Beschr).Value
      l_Bemerkung_Zeile = 1
    Else
      l_Bemerkung_Zeile = l_Bemerkung_Zeile + 1
      s_Baureihe = ws.Cells(z, c_SP_Baureihe).Value
      If s_Baureihe <>  Then
        wsz.Cells(l_zus_Zeile, c_SP_Baureihe).Value = _
        wsz.Cells(l_zus_Zeile, c_SP_Baureihe).Value &   & s_Baureihe
      End If
      s_Beschr = ws.Cells(z, c_SP_Beschr).Value
      If l_Bemerkung_Zeile = 2 Then
       ->nach erster Bermekungszeile Zeilenvorschub
        wsz.Cells(l_zus_Zeile, c_SP_Beschr).Value = _
        wsz.Cells(l_zus_Zeile, c_SP_Beschr).Value & vbLf & s_Beschr
      Else
       ->sonst Leerzeichen einfügen
        wsz.Cells(l_zus_Zeile, c_SP_Beschr).Value = _
        wsz.Cells(l_zus_Zeile, c_SP_Beschr).Value &   & s_Beschr
      End If
    End If
  Next
End Function
'********************************************************
Function ZusammenfassungFormatieren( _
    ws As Worksheet, wsz As Worksheet) As Long
 ->Formatierung des Zusammenfassungsblattes
 ->Rückgabe: nächste freie Zeile auf Zusammenfassungsblatt
    
 ->Formatierung
  With wsz.Cells
      .NumberFormat = @
      .HorizontalAlignment = xlLeft
      .VerticalAlignment = xlTop
      .WrapText = True
      .Font.Name = Arial
      .Font.Size = 10
  End With
 ->Numberformat der Beschreibung auf->wissenschaftlich'
 ->damit die Darstellung klappt
  wsz.Columns(c_SP_Beschr).NumberFormat = 0.E+00
  
 ->Spaltenbreiten
  wsz.Columns(c_SP_ArtNr).ColumnWidth = 12
  wsz.Columns(c_SP_Gruppe).ColumnWidth = 25
  wsz.Columns(c_SP_Baureihe).ColumnWidth = 25
  wsz.Columns(c_SP_Beschr).ColumnWidth = 100
 ->Überschriften aus 1.Blatt übernehmen
  With wsz.Cells(c_ZZ_UebSchr, c_SP_ArtNr)
    .Value = ws.Cells(c_ZQ_UebSchr, c_SP_ArtNr).Value
    .Font.Bold = True
  End With
  With wsz.Cells(c_ZZ_UebSchr, c_SP_Gruppe)
    .Value = ws.Cells(c_ZQ_UebSchr, c_SP_Gruppe).Value
    .Font.Bold = True
  End With
  With wsz.Cells(c_ZZ_UebSchr, c_SP_Baureihe)
    .Value = ws.Cells(c_ZQ_UebSchr, c_SP_Baureihe).Value
    .Font.Bold = True
  End With
  With wsz.Cells(c_ZZ_UebSchr, c_SP_Beschr)
    .Value = ws.Cells(c_ZQ_UebSchr, c_SP_Beschr).Value
    .Font.Bold = True
  End With
  
  With wsz.PageSetup
    .Zoom = False             ->False für FitTo...
    .FitToPagesTall = 500     ->Ausdrucklänge 500 Seiten
    .FitToPagesWide = 1       ->Ausdruckbreite 1 Seite
    .Orientation = xlLandscape->Querformat
  End With
 ->Rueckgabe der letzten beschriebenen Zeile auf Blatt->Zusammenfassung'
  ZusammenfassungFormatieren = c_ZZ_UebSchr
End Function