Hallo Gast46799,

vielen Dank für deinen Code, es läuft schon sehr gut und ich kann damit sehr viel anfangen. Ein zwei Fragen hätte ich noch, vielleicht kannst Du, oder jemand anderes mir weiter helfen.

1. Gesucht werden soll ja nach "Termin" --> Bei mehr als einem Datum steht da dummerweise "Termine". Folgerichtig findet der Code dann nichts. 
   
         
Set RngZ = Columns("A").Find(What:="Termin", LookIn:=xlValues, LookAT:=xlWhole)
         If RngZ Is Nothing Then
            Call MsgBox("Termin - Begriff fehlt", vbExclamation, "Abbruch")
            Exit Sub
         End If
         
         Set RngZ = Range(RngZ.Offset(0), rngH.Offset(-1))
         Set RngZ = RngZ.SpecialCells(2)
   
   Ich dachte ich könnte einfach die gleiche Zeile kopieren und "Termine" einfügen und im ersten Block "Exit Sub" löschen.... führt dann aber zu einem Laufzeitfehler. Gesucht werden soll also nach "Termin" und "Termine"
    
2. Es gibt außer "Termin" und "Haupttext" noch ein paar andere Textstellen deren Reihenfolge geändert werden muss. Ich dachte, wenn ich zwei Beispiele habe, dann kann ich den Rest sicher selbst umschreiben.... Pustekuchen
   
   Zurzeit sieht der "umgewandelte" Code so aus.
   

   Sub Problem123()
   Dim rngH As Range, RngT As Range, RngZ As Range, RngE As Range
    
      With ActiveSheet
         .Columns("C:C").ClearContents
         Set rngH = Columns("A").Find(What:="Haupttext", LookIn:=xlValues, LookAT:=xlWhole)
         If rngH Is Nothing Then
            Call MsgBox("Haupttext - Begriff fehlt", vbExclamation, "Abbruch")
            Exit Sub
         End If
          
         Set RngT = .UsedRange.Columns("A")
         Set RngT = RngT.Offset(rngH.Row + 1).Resize(RngT.Rows.Count - (rngH.Row + 1))
         Set RngT = RngT.SpecialCells(2)
          
         RngT.Copy .Range("C1")
          
         Set RngZ = Columns("A").Find(What:="Termin", LookIn:=xlValues, LookAT:=xlWhole)
         If RngZ Is Nothing Then
            Call MsgBox("Termin - Begriff fehlt", vbExclamation, "Abbruch")
            Exit Sub
         End If
         
         Set RngZ = Range(RngZ.Offset(0), rngH.Offset(0))
         Set RngZ = RngZ.SpecialCells(2)
         
         RngZ.Copy .Range("C" & .Rows.Count).End(xlUp).Offset(1)
         
         Set RngE = Columns("A").Find(What:="Nötig", LookIn:=xlValues, LookAT:=xlWhole)
         If RngZ Is Nothing Then
            Call MsgBox("Nötig - Begriff fehlt", vbExclamation, "Abbruch")
            Exit Sub
         End If
          
         Set RngE = Range(RngE.Offset(0), rngH.Offset(-1))
         Set RngE = RngE.SpecialCells(2)
          
         RngE.Copy .Range("C" & .Rows.Count).End(xlUp).Offset(1)
      
      End With
    
   End Sub
   

   Das Problem.... In Excel passiert dann das

Ich weiß leider nicht was ich hier falsch mache.... Es werden mehr Zellen kopiert als ich es will. In Spalte E steht, wie ich es mir vorstellen würde.

Ich würde mich über eine erneute Antwort sehr freuen. Typischer Spruch
"je mehr ich weiß um so mehr weiß ich das ich nicht(s) weiß

p.s.: Ich weiß nicht wie du deinen Code so übersichtlich mit Zahlen und Farben darstellen konntest..