Microsoft Office Forums - View Single Post - [Solved] Extract all footnotes and add them to a customized table

risefi · 07-17-2022, 09:33 AM

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:

Code:

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?