Hallo

obwohl ich schon lange Programmiere habe ich nicht allzuviel vom Vorgänger verstanden. Ist mir zu abstrakt.

Hier mal ein kleines Makro mit dem man die Aufgabe lösen kann wenn es weiter unten keine Überschriften mehr gibt. Ansonsten wird nur der 1. Block kopiert, für den nächsten Block muss man ein erweitertes makro schreiben.Den Block ab For sp = 1 to LSp kopieren und unten anfügen. Beim 2. Block muss For ze = 2 to LZe auf die Zeile des 2. Blockbereichs gesetzt werden. Würde micvh freuen wenn das makro weiterhilft.

mfg Noibody

Dim ZielAdr As String
Dim ZielAdr As String
Dim Ziel As Worksheet

Sub Überschriften_suchen()
Dim ze As Long, sp As Integer
Dim LZe As Long, LSp As Integer

With Worksheets("Tabelle1")   'Name der Starttabelle angeben
    'LastSpalte und LastZell ermitteln
    LSp = .Cells(1, Columns.Count).End(xlToLeft).Column
    LZe = .Cells(Rows.Count, 1).End(xlUp).Row

    'Name der Zieltabelle angeben
    Set Ziel = Worksheets("Zieltabelle")
    ZielAdr = "A1"  '1. Zieladresse angeben
    
    '1.Schleife sucht die Spalten Überschrift
    For sp = 1 To LSp   'Spalte A bis xxx
       If .Cells(1, sp).Font.Bold = True Then
         '2.Schleife sucht die Endzeile bis zur unteren Überschrift
          For ze = 2 To LZe   'Zeile 2 bis xxx
             If .Cells(ze, sp).Font.Bold = True Then Exit For
          Next ze
          'sp ist die gefundene Spakte mit fetter Überschrift
          'ze ist dieletzte Zeile bis unten eine Überschrift kommt
          'diesen Bereich kannman in eine andere Tabelle kopieren
           AnfAdr = .Cells(1, sp).Address
           EndAdr = .Cells(ze, sp).Address
          'gefundenen Bereich kopieren
          .Range(AnfAdr, EndAdr).Copy
           Ziel.Range(ZielAdr).PasteSpecial xlPasteAll
           Application.CutCopyMode = False
          'nächste Zieladresse setzen
           ZielAdr = Ziel.Range(ZielAdr).Offset(0, 1).Address
       End If
    Next sp
End With
End Sub