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