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