Hallo! ich bin am verzweifeln. Ich schreibe grade für Word 2010 ein Makro. Das Makro soll die Aufgabe erledigen, eine bestimmte Art von Überschriften zu finden und an diese eine bestimmte Zeichenfolge zu hängen. Um genau zu sein soll es "Überschrift 3" (also die Formatvorlage) finden.

Problem: Sobald direkt unter der Überschrift eine Tabelle folgt, gerät das Makro in eine Endlosschleife. Es findet praktisch unendlich oft die selbe Stelle und erstellt den entsprechenden Text ebenfalls unendliche male, bis ich das Makro abbreche.

Hier mein Code:

Sub LinkGenerator2()
Dim dateiname As String
dateiname = ActiveDocument.Name
'Wenn Dateiname = .doc -3. sonst -4
'dateiname = Left(dateiname, Len(dateiname) - 4)
If (Right(dateiname, 3) = "doc") Then
    dateiname = Left(dateiname, Len(dateiname) - 4)
Else
    dateiname = Left(dateiname, Len(dateiname) - 5)
End If
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