Sub IndexHyperlinker()
Application.ScreenUpdating = False
Dim Fld As Field, Rng As Range, StrIdx As String, StrList As String, i As Long, j As Long
StrList = vbCr
With ActiveDocument
  .Fields.Update
  For Each Fld In .Fields
    With Fld
      If .Type = wdFieldIndexEntry Then
        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
      End If
    End With
  Next
  Set Rng = .Indexes(1).Range
  With Rng
    .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(.Text, vbTab)(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
  End With
End With
Application.ScreenUpdating = True
End Sub

Function GetBkMk(j As Long, StrIdx As String) As String
Dim i As Long
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
    End If
  Next
End With
End Function