Sub IndexHyperlinker()
'
' IndexHyperlinker Macro
'
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(Split(.Code.Text, "XE ")(1))
          StrIdx = Replace(StrIdx, Chr(34), "")
          StrIdx = NormalizeIndexName(StrIdx)
          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: MsgBox StrIdx
          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 = Split(Split(.Text, vbTab)(0), vbCr)(0)
        StrIdx = NormalizeIndexName(StrIdx)
        .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

Function NormalizeIndexName(StrIn As String) As String
    ' Replace leading numerals with their word equivalents
    Dim NumWords(1 To 20) As String
    NumWords(1) = "first_": NumWords(2) = "second_": NumWords(3) = "third_"
    NumWords(4) = "fourth_": NumWords(5) = "fifth_": NumWords(6) = "sixth_"
    NumWords(7) = "seventh_": NumWords(8) = "eighth_": NumWords(9) = "ninth_"
    NumWords(10) = "tenth_": NumWords(11) = "eleventh_": NumWords(12) = "twelfth_"
    NumWords(13) = "thirteenth_": NumWords(14) = "fourteenth_": NumWords(15) = "fifteenth_"
    NumWords(16) = "sixteenth_": NumWords(17) = "seventeenth_": NumWords(18) = "eighteenth_"
    NumWords(19) = "nineteenth_": NumWords(20) = "twentieth_"
    
    Dim tmp As String: tmp = Trim(StrIn)
    Dim i As Integer
    For i = 20 To 1 Step -1
        If tmp Like CStr(i) & "*" Then
            tmp = NumWords(i) & Mid(tmp, Len(CStr(i)) + 1)
            Exit For
        End If
    Next i
    
    ' Replace remaining chars
    tmp = Replace(tmp, ", ", "_")
    tmp = Replace(tmp, " ", "_")
    tmp = Replace(tmp, "-", "_")
    NormalizeIndexName = tmp
End Function