Makro funktioniert nicht: Ständig im Loop gefangen

Hi.

Ich sitze jetzt schon seit Monaten an einem Makro und verstehe bzw. finde meinen Fehler nicht.

Um genau zu sein, soll das Makro eine bestimmte Überschriftenart finden und diese durch einen Text ersetzen. Das Problem an meinem Makro ist, dass es sofort in einer endlosschleife landet, sobald hinter der Überschrift direkt eine Tabelle folgt. Woran liegt das ?

Mein Makro:

Sub LinkGenerator2()

Dim dateiname As String

dateiname = ActiveDocument.Name

'Wenn Dateiname = .doc -3. sonst -4

dateiname = Left(dateiname, Len(dateiname) - 4)

Dim wortersatz As String

Dim rng As Range

Set rng = ActiveDocument.Range

With rng.Find

  .Style = ActiveDocument.Styles(wdStyleHeading3)

  'Nach dem ersten Durchlauf muss ein zweiter folgen, der nach der anderen Überschrift sucht.

  .Text = ""

  .Forward = True

  .Wrap = wdFindStop

  .Execute

  Do While .Found = True


    'packt die gefundenen texte ins select

    rng.Select

    'Selection.MoveDown Unit:=wdLine, Count:=1

    ueberschrift = rng

    ueberschrift = Left(ueberschrift, Len(ueberschrift) - 1) 'Diese Zeile setzt den Curser an die Stelle, die noch in der Reihe der Überschrift ist. Der Zeilenumbruch steht also hinter dem Curser


    'If [cursor rechts davon].Style = "Margin Note" Then

       ' [möglichkeit zur behebung des schleifenfehlers]


    'Schreibt den Text in der richtigen Formatierung

    Selection.TypeText Text:=ueberschrift


    'Hier muss noch der "C1H Topic Properties" style hinzugefügt werden

    Selection.Style = "C1H Topic Properties"

    Selection.TypeText Text:=" " & "|url=" & dateiname & "." & ueberschrift & ".htm"

    'Selection.MoveUp wdLine, 1

    Selection.MoveDown Unit:=wdLine, Count:=1

    'Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend



    .Execute




  Loop

  'MsgBox rng

End With

End Sub