Word VBA to add links to all Heading 1-CodePudding

The code below is intended to add the same hyperlink to all Heading 1 style text. (Purpose: clicking any heading brings you to the top of the document).

It works fine for the first Heading Style text. But it does not advance to the next instance.

In testing I found this was due to the line which adds the hyperlink. When this line is removed, all the Heading 1 style text is found (but of course then I can't add the link).

How can I overcome this problem?

Sub addLinksToAllTextHavingCertainStyle()
Dim r As Range
Set r = ActiveDocument.Content
  r.Find.ClearFormatting
Do
  With r.Find
    .Text = ""
    .Replacement.Text = ""
    .Style = "Heading 1"
    .Forward = True
    .Wrap = wdFindStop
    .Format = True
    .Execute
  End With
  r.Select 'for testing
  ActiveDocument.Hyperlinks.Add Anchor:=r, Address:="", SubAddress:="_top", ScreenTip:=""
Loop
End Sub

CodePudding user response：

You're looping the wrong part of the code. As written your code loops the entire find, which means it just starts over from the beginning each time.

It is only the execution of the Find that needs to be looped, the parameters you have set will remain. When Find is executed the range that the Find is executed on is redefined to the found match, so in a loop you need to collapse the range to the end to avoid the match being endlessly re-found.

Sub addLinksToAllTextHavingCertainStyle()
    Dim r As Range
    Set r = ActiveDocument.Content
    
    With r.Find
        .ClearFormatting
        .Text = ""
        .Replacement.Text = ""
        .Style = "Heading 1"
        .Forward = True
        .Wrap = wdFindStop
        .Format = True
    End With
    Do While r.Find.Execute = True
        ActiveDocument.Hyperlinks.Add Anchor:=r, Address:="", SubAddress:="_top", ScreenTip:=""
        r.Collapse wdCollapseEnd
    Loop
End Sub