Option Explicit
Sub uebertrag()
Dim s As Integer
Dim arr As Variant
Worksheets.Application.ScreenUpdating = False
For s = 2 To Worksheets("quelle").Range("A65536").End(xlUp).Row
If Worksheets("quelle").Cells(s, 1).Value = "Bedingung" Then
arr = Worksheets("quelle").Range("A" & s, "B" & s)
Worksheets("ziel").Range("A" & Worksheets("ziel").Range("A65536").End(xlUp).Row + 1, "B" & Worksheets("ziel").Range("A65536").End(xlUp).Row + 1) = arr
Do While Worksheets("quelle").Cells(s, 2) = Worksheets("quelle").Cells(s - 1, 2)
s = s + 1
Loop
End If
Next s
Worksheets("ziel").Range("A2", "B" & Worksheets("ziel").Range("A65536").End(xlUp).Row).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Cells(1, 1).Select
Worksheets.Application.ScreenUpdating = True
End Sub