Sub UnLinkNotes()
Application.ScreenUpdating = False
Dim nRng As Range, fNote As Footnote, nRef As String
With ActiveDocument
  For Each fNote In .Footnotes
    With fNote
      With .Reference.Characters.First
        .InsertAfter "]"
        .Characters.Last.Font.Superscript = True
        .Collapse wdCollapseStart
        .InsertCrossReference wdRefTypeFootnote, wdFootnoteNumberFormatted, fNote.Index
        nRef = .Characters.First.Fields(1).Result
        .Characters.First.Fields(1).Unlink
        .InsertBefore "["
        .Characters.First.Font.Superscript = True
      End With
      .Range.Cut
    End With
    Set nRng = .Range
    With nRng
      .Collapse wdCollapseEnd
      .End = .End - 1
      If .Characters.Last <> Chr(12) Then .InsertAfter vbCr
      .InsertAfter nRef & " "
      With .Paragraphs.Last.Range
        .Style = "Footnote Text"
        .Words.First.Style = "Footnote Reference"
      End With
      .Collapse wdCollapseEnd
      .Paste
      If .Characters.Last = Chr(12) Then .InsertAfter vbCr
    End With
  Next
  For Each fNote In .Footnotes
    fNote.Delete
  Next
End With
Set nRng = Nothing
Application.ScreenUpdating = True
End Sub

Sub ReLinkFootNotes()
Dim i As Integer, j As Integer, k As Integer, l As Integer, FtRng As Range
Application.ScreenUpdating = False
With ActiveDocument
  Set FtRng = Selection.Range
  With FtRng
    .Style = "Footnote Text"
    With .Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Text = "\[([0-9]{1,})\]"
      .Replacement.Text = "\1"
      .Forward = True
      .Wrap = wdFindStop
      .Format = False
      .MatchCase = False
      .MatchWholeWord = False
      .MatchAllWordForms = False
      .MatchSoundsLike = False
      .MatchWildcards = True
      .Execute Replace:=wdReplaceAll
    End With
    k = .Paragraphs(1).Range.Words(1) - 1
    j = k
    l = ActiveDocument.Footnotes.Count - k
    For i = 1 To .Paragraphs.Count
      If .Paragraphs(i).Range.Words(1) = j + 1 Then
        j = j + 1
      End If
    Next i
  End With
  For i = k + 1 To j
    StatusBar = "Finding Footnote Location: " & i + l
    With .Content.Find
      .Text = "[" & i & "]"
      .Font.Superscript = True
      .MatchWholeWord = True
      .MatchWildcards = False
      .Execute
      If .Found = True Then
        .Parent.Select
        With Selection
          .Delete
          .Footnotes.Add Range:=Selection.Range, Text:=""
        End With
      End If
    End With
  Next i
  With FtRng
    For i = k + 1 To j
      StatusBar = "Transferring Footnote: " & i + l
      With .Paragraphs(1).Range
        .Cut
        With ActiveDocument.Footnotes(i + l).Range
          .Paste
          .Words(1).Delete
          .Characters.Last.Delete
        End With
      End With
    Next i
  On Error Resume Next
  End With
  Set FtRng = Nothing
End With
Application.ScreenUpdating = True
End Sub