Sub RepairFootnotes()
Application.ScreenUpdating = False
Dim FtNt As Footnote, Rng As Range
With ActiveDocument
  Application.OrganizerCopy Source:=.AttachedTemplate.FullName, _
    Destination:=.FullName, Name:=.Styles(wdStyleFootnoteReference).NameLocal, Object:=wdOrganizerObjectStyles
  Application.OrganizerCopy Source:=.AttachedTemplate.FullName, _
    Destination:=.FullName, Name:=.Styles(wdStyleFootnoteText).NameLocal, Object:=wdOrganizerObjectStyles
  For Each FtNt In .Footnotes
    With FtNt
      With .Reference
        Set Rng = .Duplicate
        Rng.Collapse wdCollapseStart
        Do While .Characters.Last.Next.Style <> wdStyleFootnoteReference
          Rng.FormattedText = .Characters.Last.Next.FormattedText
          Rng.Collapse wdCollapseEnd
          .Characters.Last.Next.Text = ""
        Loop
        .Characters.Last.Next.Text = ""
        FtNt.Reference.Style = wdStyleFootnoteReference
      End With
      With .Range
        .Style = wdStyleFootnoteText
        .Font.Reset
        .ParagraphFormat.Reset
        .Characters.First.Style = wdStyleFootnoteReference
      End With
    End With
  Next
End With
Application.ScreenUpdating = True
End Sub