Sub FixNoteLinks()
' Turn Off Screen Updating
Application.ScreenUpdating = False
Dim i As Long
With ActiveDocument
  ' Process all Footnotes
  For i = .Footnotes.Count To 1 Step -1
    Call FixLinks(.Footnotes(i).Range)
  Next
  ' Process all Endnotes
  For i = .Endnotes.Count To 1 Step -1
    Call FixLinks(.Endnotes(i).Range)
  Next
End With
' Restore Screen Updating
Application.ScreenUpdating = True
End Sub
 
Sub FixLinks(Rng As Range)
Dim RngRef As Range, StrLnk As String, StrDisp As String
If Rng.Hyperlinks.Count = 0 Then
  Set RngRef = Rng.Duplicate
  With RngRef.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Replacement.Text = ""
    .Format = True
    .Font.ColorIndex = wdBlue
    .Font.Underline = wdUnderlineSingle
    .Execute
    If .Found Then
      StrDisp = RngRef.Duplicate.Text
      RngRef.Duplicate.Text = vbNullString
    End If
  End With
  Set RngRef = Rng.Duplicate
  With RngRef
    If InStr(.Text, Chr(19)) And InStr(RngRef.Text, Chr(20)) Then
      .Start = .Start + InStr(.Text, Chr(19)) - 1
      .End = .Start + InStr(.Text, Chr(20))
      .Characters.First.Delete
      .Characters.Last.Delete
      StrLnk = Trim(.Text)
      Rng.Fields.Add Range:=RngRef, Text:=StrLnk, Preserveformatting:=False
      Rng.Hyperlinks(1).TextToDisplay = StrDisp
    End If
  End With
End If
' Cleanup
Set RngRef = Nothing
End Sub