Do Until - Schleife verlassen funktioniert nicht.

Sub Zuordnen()
Dim letzteZeile As Integer, Nr As Integer, ZNr As Integer, TPFehlt As Integer
Dim Kopieranfang As Integer, Kopierende As Integer
Dim TP As String, TP1 As String
Nr = 0
On Error GoTo Fehler
'Application.ScreenUpdating = False
' alte Daten löschen
Sheets("Ergebnis").Select
Range("A2").Select
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
Selection.Delete Shift:=xlToLeft
' TP einlesen
Sheets("LvB").Activate
Range("X1").Select
Do Until ActiveCell.Value = ""
ActiveCell.Offset(1, 0).Select
TP = ActiveCell.Value
Kopieranfang = 2
Nr = Nr + 1
TPFehlt = 0
Sheets("Transponder").Activate
letzteZeile = Cells(Rows.Count, 2).End(xlUp).Row
Debug.Print letzteZeile
Range("b2").Select
TP1 = ActiveCell.Value
Do While TP1  TP
ActiveCell.Offset(1, 0).Select
TP1 = ActiveCell.Value
' TP1 wird nicht gefunden
If Kopieranfang = letzteZeile And TP1  TP Then
Sheets("Ergebnis").Select
Range("B1").Select
letzteZeile = Cells(Rows.Count, 2).End(xlUp).Row
ActiveCell.Offset(letzteZeile + 1, -1).Select
ActiveCell.Value = Nr
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = "TP fehlt"
TPFehlt = 1
Exit Do
End If
If IsEmpty(ActiveCell) Then Exit Do
Kopieranfang = ActiveCell.Row
Loop
Do While TP1 = TP
Kopierende = ActiveCell.Row
ActiveCell.Offset(1, 0).Select
TP1 = ActiveCell.Value
Loop
If TPFehlt = 1 Then Exit Do ' hier soll die Schleife beendet werden (Sprung zu Loop)
' aber es kommt die Fehlermeldung: Fehlernummer: 0
Range(Cells(Kopieranfang, 1), Cells(Kopierende, 20)).Copy
Sheets("Ergebnis").Select
Range("B1").Select
letzteZeile = Cells(Rows.Count, 2).End(xlUp).Row
ActiveCell.Offset(letzteZeile + 1, -1).Select
ActiveSheet.Paste
ActiveCell.Value = Nr
Sheets("LvB").Activate
Loop
Fehler:
MsgBox "Fehler aufgetreten." & vbCrLf & _
"Fehlernummer: " & Err.Number & vbCrLf & _
"Beschreibung: " & Err.Description
Application.ScreenUpdating = True
End Sub