Sub entfernen()
Dim wksT As Worksheet
Dim lRowBeendet As Long, lRowTestNr As Long
Dim Counter As Long, n As Long
Dim rngUnion As Range
n = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
Set wksT = ActiveWorkbook.Worksheets("Tabelle1")
With wksT.Cells(1).Resize(n)
For Counter = 1 To n
If Cells(Counter, 1).Value Like "*beendet*" Then
lRowBeendet = Counter
ElseIf Cells(Counter, 1).Value Like "*Testnummer*" Then
lRowTestNr = Counter
End If
If lRowBeendet + 1 <= lRowTestNr - 1 Then
If rngUnion Is Nothing Then
Set rngUnion = Rows(lRowBeendet + 1 & ":" & lRowTestNr - 1)
Else
Set rngUnion = Union(rngUnion, Rows(lRowBeendet + 1 & ":" & lRowTestNr - 1))
End If
End If
Next Counter
If Not rngUnion Is Nothing Then rngUnion.Delete shift:=xlUp
End With
End Sub