Run a VBA macro on every word in Word-File

Question

I've adapted this other answer to my needs. My changes look through the populated array and matches the selected text to the Header text instead of the Header number, as well as other some minor changes.

     Sub InsertCrossRef()
        'thank you stackoverflow:                
       https://stackguides.com/questions/47559316/macro-to-insert-a-cross-
       reference-based-on-selection
            Dim RefList As Variant 'list of all available headings and 
            numbered items available
            Dim LookUp As String 'string to be lookedup
            Dim Ref As String 'reference string in which there is to be searched
            Dim s As Integer, t As Integer 'calculated variabels for the string changes
            Dim i As Integer 'looping integer

            On Error GoTo ErrExit
            With Selection.Range


                ' discard leading blank spaces
                Do While (Asc(.Text) = 32) And (.End > .Start)
                    .MoveStart wdCharacter
                Loop
                ' discard trailing blank spaces, full stops, etc
                Do While ((Asc(Right(.Text, 1)) = 46) Or _
                          (Asc(Right(.Text, 1)) = 32) Or _
                          (Asc(Right(.Text, 1)) = 11) Or _
                          (Asc(Right(.Text, 1)) = 13)) And _
                          (.End > .Start)
                    .MoveEnd wdCharacter, -1
                Loop

        ' error protection

           ErrExit:
                If Len(.Text) = 0 Then
                    MsgBox "Please select a reference.", _
                           vbExclamation, "Invalid selection"
                    Exit Sub
                End If

                LookUp = .Text

            End With
            On Error GoTo 0

            With ActiveDocument
                ' Use WdRefTypeHeading to retrieve Headings
                RefList = .GetCrossReferenceItems(wdRefTypeNumberedItem)
                For i = UBound(RefList) To 1 Step -1
                    Ref = Trim(RefList(i))

                    If InStr(1, Ref, LookUp, vbTextCompare) = 13 Or InStr(1,                                   Ref, LookUp, vbTextCompare) = 12 Then
                        s = InStr(2, Ref, " ") 'set S = xValue when position 2 returns a Space
                        t = InStr(2, Ref, Chr(9)) 'set T = 1 when position 2 returns a Tab
                        If (s = 0) Or (t = 0) Then
                            s = IIf(s > 0, s, t)
                        Else
                            s = IIf(s < t, s, t)
                        End If

                        If LookUp = Right(Ref, Len(Ref) - s) Then Exit For

                        'If LookUp = Left(Ref, s - 1) Then Exit For
                    End If
                Next i

        ' create the cross reference, add a space when acidently a space was selected
                If i Then

                If Right(Selection.Range, 1) = " " Then

                    Selection.InsertCrossReference ReferenceType:="Numbered item", _
                                                   ReferenceKind:=wdContentText, _
                                                   ReferenceItem:=CStr(i), _
                                                   InsertAsHyperlink:=True, _
                                                   IncludePosition:=False, _
                                                   SeparateNumbers:=False, _
                                                   SeparatorString:=" "
                    Selection.InsertAfter " "

                Else
                    Selection.InsertCrossReference ReferenceType:="Numbered item", _
                                                   ReferenceKind:=wdContentText, _
                                                   ReferenceItem:=CStr(i), _
                                                   InsertAsHyperlink:=True, _
                                                   IncludePosition:=False, _
                                                   SeparateNumbers:=False, _
                                                   SeparatorString:=" "
                End If


                Else
                    MsgBox "A cross reference to """ & LookUp & """ couldn't be set" & vbCr & _
                           "because a paragraph with that number couldn't" & vbCr & _
                           "be found in the document.", _
                           vbInformation, "Invalid cross reference"
                End If
            End With
        End Sub

What I want to achieve is to run this code on every word in my document:

For Each sentence In ActiveDocument.StoryRanges
   For Each w In sentence.Words

    'above code should run        

   Next

What I expected was that the macro would run through every word in my document, see if it matches any of the headers and apply the crossreference maacro hereabove.

Kazimierz Jawor Kazimierz Jawor · Accepted Answer · 2017-12-05T10:21:41

1. Make you main subroutine parametrized in this way:

Sub InsertCrossRef(rngWord as Range)
    ...
End Sub

2. Next, inside InsertCrossRef you need to identify and change all references which should point to Word Object (rngWord). Example for you:

With Selection.Range '<< this should be changed into...
With rngWord '<<...this

And I could see one or more other to change in this way.

3. Finally, to call it for each word complete your loops in this way:

For Each sentence In ActiveDocument.StoryRanges
   For Each w In sentence.Words

      InsertCrossRef w

   Next
Next

Run a VBA macro on every word in Word-File

1 Answers