Sub Problem123()
Dim rngH As Range, RngT As Range, RngZ 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(1), rngH.Offset(-1))
Set RngZ = RngZ.SpecialCells(2)
RngZ.Copy .Range("C" & .Rows.Count).End(xlUp).Offset(2)
End With
End Sub