Sub ReLinkEndNotes()
Dim i As Long, j As Long, NtRng As Range, Rng As Range, StrNt As String
Application.ScreenUpdating = False
With ActiveDocument
  Set NtRng = Selection.Range
  Set Rng = .Range
  Rng.End = NtRng.Start
  With NtRng
    .ListFormat.ConvertNumbersToText
    .Style = "Endnote Text"
    With .Find
      .ClearFormatting
      .Text = "([0-9]{1,}).^t"
      With .Replacement
        .ClearFormatting
        .Text = "\1 "
      End With
      .Forward = True
      .Wrap = wdFindStop
      .Format = False
      .MatchCase = False
      .MatchWholeWord = False
      .MatchAllWordForms = False
      .MatchSoundsLike = False
      .MatchWildcards = True
      .Execute Replace:=wdReplaceAll
    End With
    For i = 1 To .Paragraphs.Count
      If IsNumeric(Trim(.Paragraphs(i).Range.Words(1))) Then
        With .Paragraphs(i).Range
          j = Trim(.Words(1))
          StatusBar = "Creating Endnote: " & j
          .Start = .Start + Len(j)
          .End = .End - 1
          StrNt = .Text
          .Delete
        End With
        With Rng.Find
          .Text = j
          .Format = True
          .Font.ColorIndex = wdRed
          .MatchWholeWord = True
          .MatchWildcards = False
          .Execute
          If .Found = True Then
            .Parent.Select
            With Selection
              .Text = vbNullString
              .Endnotes.Add Range:=Selection.Range, Text:=StrNt
            End With
            Rng.Start = .Parent.Start
          End If
        End With
      End If
    Next i
    .Delete
  End With
End With
Set NtRng = Nothing: Set Rng = Nothing
Application.ScreenUpdating = True
End Sub