Sub MoveFootNotes()
Application.ScreenUpdating = False
Dim RngSrc As Range, RngTgt As Range, f As Long
With ActiveDocument
  For f = .Footnotes.Count To 1 Step -1
    With .Footnotes(f)
      Set RngSrc = .Range
      Set RngTgt = .Reference
      RngSrc.End = RngSrc.End
      With RngTgt
        .Collapse wdCollapseStart
        .FormattedText = RngSrc.FormattedText
        .InsertBefore " ###"
        .Collapse wdCollapseEnd
        .InsertAfter "###"
        .Font.Reset
      End With
      .Delete
    End With
  Next
End With
Set RngSrc = Nothing: Set RngTgt = Nothing
Application.ScreenUpdating = True
End Sub