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