Sub ListFootnotes()
Dim oDoc As Document, oDocTbl As Document
Dim oTbl As Table
Dim oRng As Range
Dim lngIndex As Long
  Application.ScreenUpdating = False
  Set oDoc = ActiveDocument: Set oDocTbl = Documents.Add
   With oDocTbl
    Set oTbl = .Tables.Add(Range:=.Range, Numrows:=3, NumColumns:=2, DefaultTableBehavior:=wdWord9TableBehavior)
    oTbl.Columns(1).Cells.Merge
    Set oRng = oTbl.Range.Duplicate
     For lngIndex = 1 To oDoc.Footnotes.Count
      With oTbl
        .Cell(.Range.Information(wdEndOfRangeRowNumber) - 2, 1).Range.Text = lngIndex
        .Cell(.Range.Information(wdEndOfRangeRowNumber) - 2, 2).Range.Text = "Original:" & vbCr & oDoc.Footnotes(lngIndex).Range.FormattedText
        .Cell(.Range.Information(wdEndOfRangeRowNumber) - 1, 2).Range.Text = "Copy 1:" & vbCr & oDoc.Footnotes(lngIndex).Range.FormattedText
        .Cell(.Range.Information(wdEndOfRangeRowNumber), 2).Range.Text = "Copy 2:" & vbCr & oDoc.Footnotes(lngIndex).Range.FormattedText
      End With
      If lngIndex < oDoc.Footnotes.Count Then .Range.Characters.Last.FormattedText = oRng.FormattedText
    Next
  End With
  Application.ScreenUpdating = True
lbl_Exit:
  Exit Sub
End Sub