Footnote extraction macro [Why is this macro so slow? / anyway to make it faster?]

Le_Blanc · #1 06-07-2017, 01:13 AM

Dear all,

I hope you can assist me with the following issue. I sometimes have to extract footnotes into the body of the Word text that I am operating in. As this can be a tedious process I wrote this macro which extracts the footnotes.

Code:

Sub footnoteCharacters()
Dim i, a, c As Integer, b As String, rang As Range, fNote As Footnote
If ActiveDocument.Footnotes.count > 0 Then
For a = 1 To ActiveDocument.Footnotes.count
Selection.HomeKey Unit:=wdStory
i = 1

With Selection.Find
.Text = "^f"
.MatchWildcards = False
End With
Selection.Find.Execute

b = Selection

Do
If ActiveDocument.Characters(i) <> b Then i = i + 1
Loop Until ActiveDocument.Characters(i) = b

With ActiveDocument
c = Len(ActiveDocument.Footnotes(1).Range)
.Footnotes(1).Range.Cut
.Characters(i).Paste
.Characters(i + c).InsertAfter " £$%"
.Characters(i).InsertBefore "%$£"
End With


Next a
End If
End Sub

What this macro does is, that it first checks for any footnotes in the document. If there are any it matches characters until it reaches the footnote (this way the exact position of the footnote in the document can be determined), upon which it extras the footnote to where formerly the footnote number was and it surrounds the extracted text with "%$£", so the footnote beginning and the end can be easily identified.

The problem is that if this code is executed on a longer document (By longer I mean anything as short as 1000 words), it can take very long for this macro to finish working (10 minutes +), even if it does (It works just fine on shorter documents). The problem obviously is the character matching, but I don't see why this would take so long, given that the computer should be able to match hundreds of symbols a second. I also tried doing a similar macro which counts words and not symbols in order to determine the location of the footnote in the text, but that one is unfortunately not working, even through the search / matching is faster. I was not able to determine the reason for its malfunction.

Code:

Sub footnoteWords()
Dim i, c As Integer, b As String  'create a bit of documentary on these so we dont have any duplification + range empty?

If ActiveDocument.Footnotes.count > 0 Then

For a = 1 To ActiveDocument.Footnotes.count
Selection.HomeKey Unit:=wdStory
i = 1

With Selection.Find
.Text = "^f"
.MatchWildcards = False
End With
Selection.Find.Execute

Selection = b

Do
If ActiveDocument.Words(i) <> b Then i = i + 1
Loop Until ActiveDocument.Words(i) = b

With ActiveDocument
c = ActiveDocument.Footnotes(1).Range.Words.count
.Footnotes(1).Range.Cut
.Words(i).Paste
.Words(i + c).InsertAfter "£$%"
.Words(i).InsertBefore "%$£"
End With

Next a
End If
End Sub

Do tell me if you have any idea how to make the first macro faster (even telling me why it is so slow would be a big help) or how I could make the second macro work.

Thanks for any feedback!

gmayor · #2 06-07-2017, 02:29 AM

You are overthinking this. Try the following

Code:

Sub footnoteCharacters()
'Graham Mayor - http://www.gmayor.com - Last updated - 07 Jun 2017 
Dim oFNote As Footnote
Dim oRng As Range
Dim i As Integer, j As Integer
    For i = ActiveDocument.Footnotes.Count To 1 Step -1
        Set oFNote = ActiveDocument.Footnotes(i)
        Set oRng = oFNote.Reference.Characters.Last
        oRng.Text = " £$%" & oFNote.Range.Text & "%$£"
        DoEvents
    Next i
lbl_Exit:
    Set oFNote = Nothing
    Set oRng = Nothing
    Exit Sub
End Sub

Le_Blanc · #3 06-07-2017, 03:58 AM

Quote:

You are overthinking this

If I got a dollar for each time I heard this in my life haha...

This is indeed a fantastic solution gmayor! And it is also executed in no time. Thank you a lot!

gmayor · #4 06-07-2017, 04:10 AM

If I got a dollar for every suggestion that worked .....

RiSta · #5 06-13-2020, 11:55 AM

Thanks for macro. Is it possible that macro returns text not in superscript format, but it should preserve formating style of footnote for example keep italic or bold?

macropod · #6 06-13-2020, 08:34 PM

See: https://www.msofficeforums.com/word/...tes-which.html

RiSta · #7 06-14-2020, 06:24 AM

Quote:

Originally Posted by macropod

See: https://www.msofficeforums.com/word/...tes-which.html

how can I add symbols ** before and after footnote?

gmaxey · #8 06-14-2020, 07:35 AM

By modifying slightly

Code:

Sub MoveFootNotes()
Application.ScreenUpdating = False
Dim RngSrc As Range, RngTgt As Range, f As Long
With ActiveDocument
  For f = .Footnotes.Count To 1 Step -1
    With .Footnotes(f)
      Set RngSrc = .Range
      Set RngTgt = .Reference
      RngSrc.End = RngSrc.End
      With RngTgt
        .Collapse wdCollapseStart
        .FormattedText = RngSrc.FormattedText
        .InsertBefore " ###"
        .Collapse wdCollapseEnd
        .InsertAfter "###"
        .Font.Reset
      End With
      .Delete
    End With
  Next
End With
Set RngSrc = Nothing: Set RngTgt = Nothing
Application.ScreenUpdating = True
End Sub

RiSta · #9 06-14-2020, 08:21 AM

It works perfect. Thank you.

macropod · #10 06-14-2020, 04:16 PM

Quote:

Originally Posted by RiSta

how can I add symbols ** before and after footnote?

Kindly don't ask the same question in multiple threads. Doing so merely wastes people's time - as it has done in this case with answers being provided in both threads.

RiSta · #11 03-22-2021, 11:38 AM

Hello

Facing one problem with this macro - in some cases, after moving a footnote to a new position, footnote text accepts destination formatting. It happens when footnote text contains few lines devided by paragraph mark. Is it possible to modify macro so that is preserves footnotes original format.

Code:

Sub MoveFootNotes()
Application.ScreenUpdating = False
Dim RngSrc As Range, RngTgt As Range, f As Long
With ActiveDocument
  For f = .Footnotes.Count To 1 Step -1
    With .Footnotes(f)
      Set RngSrc = .Range
      Set RngTgt = .Reference
      RngSrc.End = RngSrc.End
      With RngTgt
        .Collapse wdCollapseStart
        .FormattedText = RngSrc.FormattedText
        .InsertBefore " ###"
        .Collapse wdCollapseEnd
        .InsertAfter "###"
        .Font.Reset
      End With
      .Delete
    End With
  Next
End With
Set RngSrc = Nothing: Set RngTgt = Nothing
Application.ScreenUpdating = True
End Sub

Thread Tools
Show Printable Version Email this Page
Display Modes
Linear Mode Switch to Hybrid Mode Switch to Threaded Mode

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Make macro available to all PPT presentations	djlee	PowerPoint	2	02-11-2015 12:52 PM
Help make Macro Please	ddaniels	Word VBA	1	01-13-2015 05:36 PM
VBA code for Microsoft Word macro — select text and insert footnote	ndnd	Word VBA	10	01-06-2015 01:47 PM
Macro to find text only footnote numbers	TimFromPhx	Word VBA	7	04-10-2014 07:05 PM
How to make an add-in/global macro	hanvyj	Excel Programming	4	12-14-2012 03:23 AM