Sub ExportFootnotes()
Dim Rng As Range, StrOut As String, StrTmp As String, i As Long, j As Long, xlApp As Object, xlWkBk As Object
StrOut = "Reference,Footnote #,Footnote Text"
StrOut = Replace(StrOut, ",", vbTab)
With ActiveDocument
  ' Process the Footnotes
  For i = 1 To .Footnotes.Count
    With .Footnotes(i)
      Set Rng = .Reference.Words.First.Previous.Words.First
      With Rng
        Do While .Words.First.Previous.Font.Italic = True
          .Start = .Words.First.Previous.Words.First.Start
        Loop
        If InStr(.Text, " v ") = 0 Then .Start = .Words.Last.Start
      End With
      StrOut = StrOut & vbCr & Rng.Text & vbTab & _
        i & vbTab & Replace(Replace(.Range.Text, vbTab, "<TAB>"), vbCr, "<P>")
    End With
  Next
End With
' Test whether Excel is already running.
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
'Start Excel if it isn't running
If xlApp Is Nothing Then
  Set xlApp = CreateObject("Excel.Application")
  If xlApp Is Nothing Then
    MsgBox "Can't start Excel.", vbExclamation
    Exit Sub
  End If
End If
On Error GoTo 0
With xlApp
  Set xlWkBk = .Workbooks.Add
  ' Update the workbook.
  With xlWkBk.Worksheets(1)
    For i = 0 To UBound(Split(StrOut, vbCr))
      StrTmp = Split(StrOut, vbCr)(i)
        For j = 0 To UBound(Split(StrTmp, vbTab))
          .Cells(i + 1, j + 1).Value = Split(StrTmp, vbTab)(j)
        Next
    Next
    .Columns("A:C").AutoFit
  End With
  ' Tell the user we're done.
  MsgBox "Done.", vbOKOnly
  ' Switch to the Excel workbook
  .Visible = True
End With
' Release object memory
Set xlWkBk = Nothing: Set xlApp = Nothing
End Sub