Private Sub CommandButton1_Click()

With ActiveDocument

.AutoHyphenation = False

With .Range
With .Find

Dim xRange As Range
Set xDoc = ActiveDocument
If xDoc.Footnotes.Count > 0 Then
Set xRange = xDoc.Footnotes(1).Range
xRange.WholeStory
xRange.Select

ActiveDocument.Paragraphs.Add
ActiveDocument.Content.InsertAfter "Footnotes"
ActiveDocument.Paragraphs.Add

Selection.Copy
Set Range2 = ActiveDocument.Content
Range2.Collapse Direction:=wdCollapseEnd

Range2.Paste

.Text = "^f"
.Replacement.Text = "<footnote>"
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
.ClearFormatting
.Replacement.ClearFormatting
.Format = True
.Forward = True
.MatchWildcards = True
.Wrap = wdFindContinue
.Font.Underline = True

End If
End With
End With

Dim wholeDoc As Document
Dim wholeRange As Range
Set wholeDoc = ActiveDocument
Set wholeRange = wholeDoc.Range(Start:=0, End:=0)
wholeRange.WholeStory
wholeRange.Select
Selection.Copy
Set Range3 = ActiveDocument.Content
Range3.Collapse Direction:=wdCollapseEnd
Application.ScreenUpdating = False
Application.ScreenUpdating = True

.Text = ""
.Replacement.Text = "<u>^&</u>"
.Execute Replace:=wdReplaceAll
.ClearFormatting
.Highlight = True
.Replacement.Text = "<h>^&</h>"
.Execute Replace:=wdReplaceAll
.ClearFormatting
.Font.Bold = True
.Replacement.Text = "<b>^&</b>"
.Execute Replace:=wdReplaceAll
.ClearFormatting
.Font.Italic = True
.Replacement.Text = "<i>^&</i>"
.Execute Replace:=wdReplaceAll

End With

Documents.Add ("12pt Template")

With ActiveDocument
Set myRange = Selection.Range
myRange.WholeStory
Selection.PasteSpecial DataType:=wdPasteText

EmphasisFormatClean

WPDFormat

End With
Unload Me

End Sub

Private Sub NewDocPlusFootnotes()
  Dim arrFN() As String, aFN As Footnote, iFN As Integer
  Dim xDoc As Document, xNewDoc As Document, aRng As Range
  
  Set xDoc = ActiveDocument
  With xDoc
    'Get the footnotes into a string array
    If xDoc.Footnotes.Count > 0 Then
      '.Footnotes.StartingNumber = 0
      ReDim arrFN(1 To xDoc.Footnotes.Count)
      For Each aFN In .Footnotes
        aFN.Reference.InsertBefore "<fNote "
        aFN.Reference.InsertAfter "/>"
        arrFN(aFN.Index) = aFN.Range
      Next aFN
    End If
  End With
  
  'Create new document and fill with plain text
  Set xNewDoc = Documents.Add
  xNewDoc.Range.Text = xDoc.Range.Text      'unformatted text into new doc
  
  'rebuild the footnotes
  Set aRng = xNewDoc.Range
  With aRng.Find
    .ClearFormatting
    For iFN = LBound(arrFN) To UBound(arrFN)
      .Text = "<fNote " & Chr(2) & "/>"
      If .Execute = True Then
        aRng.Text = ""
        xNewDoc.Footnotes.Add Range:=aRng, Text:=arrFN(iFN)
      End If
      aRng.Collapse Direction:=wdCollapseEnd
    Next iFN
  End With
End Sub