Option Explicit
 
Sub RepairEndNotes()
Application.ScreenUpdating = False
Dim Rng As Range, NtRng As Range, RngNt As Range
Dim i As Long, j As Long, eNote As Endnote
With ActiveDocument
  .Styles("Endnote Text").ParagraphFormat.SpaceAfter = 6
  Set Rng = .Range.Characters.Last
  For Each eNote In .Endnotes
    i = i + 1
    StatusBar = "Extracting Endnote: " & i
    With eNote
      Set NtRng = .Reference.Characters.First
      NtRng.End = .Reference.End
      With NtRng
        Do While .Characters.Last.Next.Font.Superscript = True
          If .Characters.Last.Next.Text = vbCr Then
            .Characters.Last.Next.Font.Superscript = False
            Exit Do
          End If
          .Characters.Last.Next.Text = vbNullString
        Loop
        Do While .Characters.First.Previous.Font.Superscript = True
          If .Characters.First.Previous.Text = vbCr Then
            .Characters.First.Previous.Font.Superscript = False
            Exit Do
          End If
          .Characters.First.Previous.Text = vbNullString
        Loop
        .InsertBefore "{" & i & "}"
        .Font.Superscript = True
      End With
      .Range.Cut
    End With
    Set NtRng = .Range
    With NtRng
        While .Characters.Last.Previous.Text = Chr(13)
          .Characters.Last.Previous.Text = vbNullString
        Wend
      .Collapse wdCollapseEnd
      .InsertAfter vbCr & "[" & i & "]"
      .Font.Superscript = True
      With .Paragraphs.Last.Range
        .Style = "Endnote Text"
        .Words.First.Style = "Endnote Reference"
      End With
      .Collapse wdCollapseEnd
      .Paste
    End With
  Next
  DoEvents
  StatusBar = "Deleting All Endnotes!"
  For Each eNote In .Endnotes
    eNote.Delete
  Next
  DoEvents
  With .Content
    With .Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Forward = True
      .Wrap = wdFindStop
      .Format = True
      .MatchCase = False
      .MatchWholeWord = False
      .MatchAllWordForms = False
      .MatchSoundsLike = False
      .MatchWildcards = True
      .Text = "\[([0-9]{1,})\]"
      .Font.Superscript = True
      .Replacement.Text = ""
      .Execute
    End With
    If .Find.Found Then Set NtRng = .Duplicate
    ' Find more qualifying Endnote content
    Do While .Find.Found
      .Collapse wdCollapseEnd
      .Find.Execute
    Loop
    NtRng.End = .Duplicate.Paragraphs.Last.Range.End
    ' Eliminate the 'marker' text and ensure each Endnote consists of one paragraph
    With NtRng.Find
      .MatchWildcards = True
      .Wrap = wdFindStop
      .Text = "[^11^13]{1,}"
      .Replacement.Text = "^l"
      .Execute Replace:=wdReplaceAll
      .Text = "\[([0-9]{1,})\]"
      .Replacement.Text = "^p\1"
      .Execute Replace:=wdReplaceAll
    End With
    NtRng.End = NtRng.End + 1
    NtRng.Characters.First.Delete
    j = NtRng.Words.First - 1
    DoEvents
    For i = 1 To NtRng.Paragraphs.Count
      StatusBar = "Rebuilding Endnote Reference: " & i + j
      With .Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchWholeWord = True
        .MatchWildcards = False
        .Text = "{" & i + j & "}"
        .Font.Superscript = True
        .Execute
      End With
      If .Find.Found = True Then
        Set RngNt = .Duplicate
        RngNt.Text = vbNullString
        .Endnotes.Add Range:=RngNt, Text:=""
        Set RngNt = NtRng.Paragraphs(i).Range
        With RngNt
          .End = .End - 2
          .Start = .Words(2).Start
          .Cut
        End With
        With ActiveDocument.Endnotes(i).Range
          .Collapse wdCollapseEnd
          .Paste
          If Trim(.Words.First.Text) Like "[0-9]" Then .Words.First.Text = vbNullString
          If Trim(.Words.First.Text) = "." Then .Words.First.Text = vbNullString
        End With
      End If
      DoEvents
    Next i
    NtRng.Text = vbNullString
  End With
End With
ErrExit:
Set NtRng = Nothing: Set RngNt = Nothing
StatusBar = "Done!!"
Application.ScreenUpdating = True
End Sub