Sub IndexHyperlinker()
' Sourced from: https://www.msofficeforums.com/word/36257-use-hyperlink-page-number-index.html
Application.ScreenUpdating = False
Dim Fld As Field, Rng As Range, StrIdx As String, StrList As String, IdxTxt As String, i As Long, j As Long
StrList = vbCr
With ActiveDocument
  If .Indexes.Count = 0 Then
    If (.Bookmarks.Exists("_INDEX") = False) Or (.Bookmarks.Exists("_IdxRng") = False) Then
      MsgBox "No Index found in this document", vbExclamation: Exit Sub
    End If
  End If
  .Fields.Update
  For Each Fld In .Fields
    With Fld
      Select Case .Type
        Case wdFieldIndexEntry
          StrIdx = Trim(Replace(Replace(Split(.Code.Text, "XE ")(1), ", ", "_"), Chr(34), ""))
          If InStr(StrList, vbCr & StrIdx & ",") = 0 Then
            i = 0: StrList = StrList & StrIdx & "," & i & vbCr
          Else
            i = Split(Split(StrList, vbCr & StrIdx & ",")(1), vbCr)(0)
          End If
          StrList = Replace(StrList, StrIdx & "," & i & vbCr, StrIdx & "," & i + 1 & vbCr)
          i = i + 1: Set Rng = .Code
          With Rng
            .Start = .Start - 1: .End = .End + 1
            .Bookmarks.Add Name:=StrIdx & i, Range:=.Duplicate
          End With
        Case wdFieldIndex: IdxTxt = "SET _" & Fld.Code
        Case wdFieldSet: IdxTxt = Split(Fld.Code, "_")(1)
      End Select
    End With
  Next
  If (.Bookmarks.Exists("_INDEX") = True) And (.Bookmarks.Exists("_IdxRng") = True) Then _
    .Fields.Add Range:=.Bookmarks("_IdxRng").Range, Type:=wdFieldEmpty, Text:=IdxTxt, Preserveformatting:=False
  Set Rng = .Indexes(1).Range
  With Rng
    IdxTxt = "SET _" & Trim(.Fields(1).Code)
    .Fields(1).Unlink
    If Asc(.Characters.First) = 12 Then .Start = .Start + 1
    For i = 1 To .Paragraphs.Count
      With .Paragraphs(i).Range
        StrIdx = Replace(Split(Split(.Text, vbTab)(0), vbCr)(0), ", ", " ")
        .MoveStartUntil vbTab, wdForward: .Start = .Start + 1: .End = .End - 1
        For j = 1 To .Words.Count
          If IsNumeric(Trim(.Words(j).Text)) Then
            .Hyperlinks.Add Anchor:=.Words(j), SubAddress:=GetBkMk(Trim(.Words(j).Text), StrIdx), TextToDisplay:=.Words(j).Text
          End If
        Next
      End With
    Next
    .Start = .Start - 1: .End = .End + 1: .Bookmarks.Add Name:="_IdxRng", Range:=.Duplicate
    .Collapse wdCollapseStart: .Fields.Add Range:=Rng, Type:=wdFieldEmpty, Text:=IdxTxt, Preserveformatting:=False
  End With
End With
Application.ScreenUpdating = True
End Sub

Function GetBkMk(j As Long, StrIdx As String) As String
Dim i As Long: GetBkMk = "Error!"
With ActiveDocument
  For i = 1 To .Bookmarks.Count
    If InStr(.Bookmarks(i).Name, StrIdx) = 1 Then
      If .Bookmarks(i).Range.Information(wdActiveEndAdjustedPageNumber) = j Then _
        GetBkMk = .Bookmarks(i).Name: Exit For
    End If
  Next
End With
End Function

Sub MakeBookmarks()
    Dim Fld As Field
    Dim bktext As String
    Dim Rng As Range

    With ActiveDocument
      .Fields.Update
          
        ' Loop through Index fields and turn each one into a bookmark in the form p###xxxxxxxx where ### is the page number and xxxxxxxx is
        ' the text of the sub entry that will appear in the index. Special characters are replaced with underscores.
        For Each Fld In .Fields
            If Fld.Type = wdFieldIndexEntry Then
                bktext = clnText(Fld.Code.Text) ' clean the index entry for use as a bookmark name
                Set Rng = .Range(Fld.Code.Start - 2, Fld.Code.End + 2) ' create a range to use for the bookmark, start and end should be in the visible text
                bktext = Left("p" & Rng.Information(wdActiveEndAdjustedPageNumber) & bktext, 40)
                If Not .Bookmarks.Exists(bktext) Then .Bookmarks.Add bktext, Rng
                'Debug.Print bkText
            End If
        Next
            
    End With
   
End Sub

Function clnText(s As String)
    ' Input is the text from a Word index entry field, return is a string that is suitable for use as a bookmark name
    ' This function extracts the final sub-entry from the input string (everything after the last colon)
    ' and replaces all chars that are not allowed in bookmark names with an underscore
    
    Dim i As Integer
    
    ' first get rid of the XE prefix, quotes and any leading or trailing spaces, chr147 and chr148 are curly quotes
    s = Trim(Replace(Replace(Replace(Replace(s, """", ""), Chr$(147), ""), Chr$(148), ""), " XE ", ""))
    ' if this is a sub-entry, just take the chars after the final :
    If InStrRev(s, ":") > 0 Then s = Trim(Right(s, Len(s) - InStrRev(s, ":")))
    ' replace all remaining non alpha-numeric chars with underscore
    For i = 1 To Len(s)
        If Mid(s, i, 1) Like "[!A-Za-z0-9]" Then Mid(s, i, 1) = "_"
    Next
    clnText = s
End Function

Sub IndexHyperlinker()
' Sourced from: https://www.msofficeforums.com/word/36257-use-hyperlink-page-number-index.html
Dim Rng As Range
Dim StrIdx As String
Dim j As Integer
Dim bktext As String

With ActiveDocument
  Set Rng = .Indexes(1).Range
  With Rng
    .Fields(1).Unlink ' replace index field with its text
    If Asc(.Characters.First) = 12 Then .Start = .Start + 1 ' if first char is a form feed, go to next line
    For i = 1 To .Paragraphs.Count
      With .Paragraphs(i).Range ' each paragraph is one line in the index text
        StrIdx = Split(Split(.Text, vbTab)(0), vbCr)(0) ' extract the index entry from current paragraph
        .MoveStartUntil vbTab, wdForward: .Start = .Start + 1: .End = .End - 1 ' find the page numbers in a comma separated list after the tab char
        For j = 1 To .Words.Count ' loop through the page numbers
          If IsNumeric(Trim(.Words(j).Text)) Then
            bktext = Left("p" & Trim(.Words(j).Text) & clnText(StrIdx), 40) ' reconstruct the name of the bookmark we created at the XE field location
            If ActiveDocument.Bookmarks.Exists(bktext) Then
                .Hyperlinks.Add Anchor:=.Words(j), SubAddress:=bktext, TextToDisplay:=.Words(j).Text
            Else
                Debug.Print "bookmark not found: " & bktext & "*"
            End If
          End If
        Next
      End With
    Next
  End With
End With
End Sub