|
|
Thread Tools | Display Modes |
#1
|
|||
|
|||
Footnote extraction macro [Why is this macro so slow? / anyway to make it faster?]
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 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 Thanks for any feedback! |
#2
|
||||
|
||||
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
__________________
Graham Mayor - MS MVP (Word) (2002-2019) Visit my web site for more programming tips and ready made processes www.gmayor.com |
#3
|
|||
|
|||
Quote:
This is indeed a fantastic solution gmayor! And it is also executed in no time. Thank you a lot! |
#4
|
||||
|
||||
If I got a dollar for every suggestion that worked .....
__________________
Graham Mayor - MS MVP (Word) (2002-2019) Visit my web site for more programming tips and ready made processes www.gmayor.com |
#5
|
|||
|
|||
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?
|
#6
|
||||
|
||||
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#7
|
|||
|
|||
Quote:
|
#8
|
|||
|
|||
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 |
#9
|
|||
|
|||
It works perfect. Thank you.
|
#10
|
||||
|
||||
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.
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#11
|
|||
|
|||
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 Last edited by macropod; 03-22-2021 at 01:56 PM. Reason: Added code tags |
Tags |
footnotes |
|
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 |