Extract all footnotes and add them to a customized table

[risefi]

I want to extract all footnotes from one document and add them to a customized table in another document. One thing that is very important is that I need it to keep the formatting when it copies the footnote over.


For the customized table, I need 2 columns. In column 1, every 3 rows are merged together, and the cell will be labelled with the footnote number. For column 2, each row is labelled "original", "copy 1", and "copy 2" repeating. I need to take all footnotes from one document and copy each footnote into the table, with copies of each footnote appearing in the original, copy 1, and copy 2 rows respectively. I need the size of the table to be created based on the number of footnotes.


Since that's difficult to describe in words, I've attached a picture of the format of the table.


Thus far, here is the code that I have which doesn't work properly:

Sub afntotable()

Dim afn As Footnote
Dim docsource As Document
Dim doctarget As Document
Dim rngtarget As Range
Set docsource = ActiveDocument
'Set doctarget = Documents.Add
Dim fncount As Integer

With docsource
    For Each afn In .Footnotes
    fncount = fncount + 1
    
    Next
End With

 Dim docNew As Document
 Dim tblNew As Table
 Dim intX As Integer
 Dim intY As Integer
 
 Set docNew = Documents.Add
 Set tblNew = docNew.Tables.Add(Selection.Range, fncount * 3, 2)
 With tblNew
     For intX = 1 To (fncount * 3) Step 3

         .Cell(intX, 2).Range.InsertAfter "Original:"

     Next intX
    For intX = 2 To (fncount * 3) Step 3
    .Cell(intX, 2).Range.InsertAfter "Copy 1:"
    Next intX
        For intX = 3 To (fncount * 3) Step 3
    .Cell(intX, 2).Range.InsertAfter "Copy 2:"
    Next intX
    

'merge rows in column 1
Dim cellnum As Integer
cellnum = 1

For cellnum = 1 To ((fncount * 3) - 1) Step 3
    .Cell(Row:=cellnum, Column:=1).Merge _
    MergeTo:=.Cell(Row:=cellnum + 1, Column:=1)

Next
cellnum = 1
For cellnum = 1 To ((fncount * 3) - 1) Step 3
    .Cell(Row:=cellnum, Column:=1).Merge _
    MergeTo:=.Cell(Row:=cellnum + 2, Column:=1)
Next

    'column size
    .PreferredWidthType = wdPreferredWidthPercent
    .Columns(1).PreferredWidth = 13
    .Columns(2).PreferredWidth = 86.9


'add footnotes
'right now it's only adding the last footnote to every third cell

With tblNew
For intX = 1 To ((fncount * 3) - 1) Step 3
For Each afn In docsource.Footnotes
.Cell(intX, 2).Range.InsertAfter "Original:"
 .Cell(intX, 2).Range.Collapse wdCollapseEnd
 .Cell(intX, 2).Range.FormattedText = afn.Range.FormattedText
         .Cell(intX, 2).Range.Collapse wdCollapseEnd
         .Cell(intX, 2).Range.InsertAfter vbCr
     Next
 
  Next

  End With
        
 End With
 'turn borders on
With tblNew.Borders
.InsideLineStyle = wdLineStyleSingle
.OutsideLineStyle = wdLineStyleSingle

End With


End Sub

While this accurately creates the table format, I'm having trouble getting it to add the footnotes correctly. Right now, it's only adding the last footnote from the source document into all of the "Original" rows instead of adding each footnote into their own "original", "copy 1", and "copy 2" rows. It's also deleting the labels for "original", "copy 1", and "copy 2".



I am also unsure of how I can copy the footnote "number" over accurately into the first column if some of the footnotes appear as symbols, thus throwing off the numbering. I'd want the same symbol or number that appears in the source document to appear in column 1.


There might be an easy solution to this, but I'm not a programmer. I took a couple of beginner programming classes over a decade ago, but that's about it. I just think it would be ridiculous to copy all of these footnotes over by hand for thousands of footnotes, so a macro would help me increase my productivity by quite a lot.


Can anyone help?

[macropod]

Try:

Sub Demo()
Application.ScreenUpdating = False
Dim DocSrc As Document, DocTgt As Document, Tbl As Table, Rng As Range, FtNt As Footnote, i As Long
Set DocSrc = ActiveDocument: Set DocTgt = Documents.Add
With DocTgt
  Set Tbl = .Tables.Add(Range:=.Range, Numrows:=3, NumColumns:=2, DefaultTableBehavior:=wdWord9TableBehavior)
  With Tbl
    .Columns(1).Cells.Merge
    .Cell(1, 2).Range.Text = "Original:" & vbCr
    .Cell(2, 2).Range.Text = "Copy 1:" & vbCr
    .Cell(3, 2).Range.Text = "Copy 2:" & vbCr
  End With
  Set Rng = Tbl.Range
  For i = 1 To DocSrc.Footnotes.Count - 1
    .Range.Characters.Last.FormattedText = Rng.FormattedText
  Next
  For i = 1 To DocSrc.Footnotes.Count
    With Tbl
      .Cell((i - 1) * 3 + 1, 1).Range.Text = i
      .Cell((i - 1) * 3 + 1, 2).Range.Characters.Last.Text = DocSrc.Footnotes(i).Range.FormattedText
      .Cell((i - 1) * 3 + 2, 2).Range.Characters.Last.Text = DocSrc.Footnotes(i).Range.FormattedText
      .Cell((i - 1) * 3 + 3, 2).Range.Characters.Last.Text = DocSrc.Footnotes(i).Range.FormattedText
    End With
  Next
End With
Application.ScreenUpdating = True
End Sub

[gmaxey]

I was working on this before I had to leave for a short trip yesterday. Was thinking along the same lines as Paul - and not that it makes a big difference - but was wanting to avoid the two loops. Here is my version:

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