#1
|
|||
|
|||
Macro running very slowly, and possibly looping
Hi, Well, despite Paul's advice to not reinvent the wheel, I decided to roll my own, and it worked, until I realized that I'd not searched footnotes/endnotes etc. Before I looped through ranges, it took about 7 minutes to run on a 330 page document. Two questions: 1.is there an accessible way to find out what's going on. 2.How can I optimize this. Code:
Option Explicit Sub BibleIndex() ' ' BibleIndex Macro ' Marks scripture references prepatory to creating/updating an index ' Dim strBksAbb As String strBksAbb = "Mt,Mk,Lk,Jn,Ac,Rom,1 Co,2 Co,Gal,Eph,Ph,Col,1 Th,2 Th,1 Ti,2 Ti,Tit,Pm,Heb,Jas,1 Pe,2 Pe,1 Jn,2 Jn,3 Jn,Ju,Rev" Dim arrBksAbb() As String arrBksAbb = Split(strBksAbb, ",") Dim strBks As String strBks = "MATTHEW,MARK,LUKE,JOHN,ACTS,ROMANS,1 CORINTHIANS,2 CORINTHIANS,GALATIONS,EPHESIANS,PHILIPPIANS,COLOSSIANS,1 THESSALONIANS,2 THESSALONIANS,1 TIMOTHY,2 TIMOTHY,TITUS,PHILEMON,HEBREWS,JAMES,1 PETER,2 PETER,1 JOHN,2 JOHN,3 JOHN,JUDE,REVELATION" Dim arrBks() As String arrBks = Split(strBks, ",") Dim intIdx1, intIdx2, intBookNo As Integer Dim strBook, strBookNo, strBkAbb, strChapVerses, strChapter, strVerses, strFrom, strTo As String Dim strRef, strTmp, strPrompt As String Dim strFind As String Dim intCount As Integer intCount = 0 strFind = "<[0-9A-Z]{1,2}[a-z.]{2,3} [0-9]{1,}:[!^s .,;”\)]{1,}" Dim myRange As Range, strXE As String ActiveWindow.View.ShowHiddenText = False For Each myRange In ActiveDocument.StoryRanges Do With myRange.Find .ClearFormatting .Wrap = wdFindStop .MatchWildcards = True .Text = strFind Do While .Execute strRef = Trim(myRange.Text) strBkAbb = Split(strRef, ".")(0) For intIdx1 = 0 To 26 If strBkAbb = arrBksAbb(intIdx1) Then intCount = intCount + 1 strChapVerses = Trim(Split(strRef, ".")(1)) strChapter = Split(strChapVerses, ":")(0) strVerses = Split(strChapVerses, ":")(1) strFrom = Split(strVerses, Chr(150))(0) If InStr(strVerses, Chr(150)) > 0 Then strTo = Split(strVerses, Chr(150))(1) Else strTo = "00" If strFrom = strTo Then strTo = "00" strTmp = strChapVerses strChapVerses = "" For intIdx2 = 1 To Len(strTmp) If Mid(strTmp, intIdx2, 1) = ":" Then strChapVerses = strChapVerses & "" strChapVerses = strChapVerses & Mid(strTmp, intIdx2, 1) Next intIdx2 strChapter = Format(strChapter, "000") strFrom = Format(strFrom, "000") strTo = Format(strTo, "000") strBookNo = Format(CStr(intIdx1 + 1), "000") strXE = arrBks(intIdx1) & ";" & strBookNo & ":" & strChapVerses & ";" & strBookNo & strChapter & strFrom & strTo myRange.Font.ColorIndex = wdRed ActiveDocument.Indexes.MarkEntry Range:=myRange, Entry:=strXE Exit For End If Next intIdx1 Loop End With Set myRange = myRange.NextStoryRange Loop Until myRange Is Nothing Next strPrompt = CStr(intCount) & " Entries marked for indexing" MsgBox strPrompt, vbOKOnly End Sub Last edited by macropod; 02-24-2021 at 02:01 AM. Reason: Added code tags |
#2
|
|||
|
|||
Macro running very slowly, and possibly looping
Hi,
Despite Paul's war4nings, I decided to roll my own bible indexing macro. It worked! Until a couple of days ago, when I realized that I'd not picked up references contained in footnotes/endnotes. I put some extra code in to accomodate this, but everything seems to stand still for a very long time. What did I do wrong? Code:
Sub BibleIndex() ' BibleIndex Macro ' Creates biblical index ' Dim myRange As Range, fRange As Range Dim blnStarted As Boolean Dim arrBooks(1 To 27) As String Dim arrOnlyOne(1 To 27) As Boolean Dim arrFullBooks() As String Dim strFullBooks As String Dim strVersePages As String Dim intNoMarks, intNoRefs, intChapter1, intChapter2 As Integer Dim intViewType As Integer Dim intVerse As Integer Dim intJidx, intKidx, intLidx, intJ, intK, intL As Integer Dim intXRef As Integer, intRangeSelect As Integer Dim blnOnlyOne, blnFound, blnInList As Boolean Dim strFindText As String Dim strFoundText As String, strStory As String Dim arrFoundText() As String Dim arrVerseList(), arrVerseSort(), arrVersePages() As String Dim arrSortPages() As Integer Dim intPages() As Integer Dim arrVerseRef() As String Dim strChapterVerse1, strChapterVerse2, strChapter1, strVerse1strVerse2, strChapter2, strVerse, strTidyVerse, strPages As String Dim intPageNo As Integer Dim strPageNo As String Dim strVersePage As String Dim intTotalRefs As Integer arrBooks(1) = "Mt" arrBooks(2) = "Mk" arrBooks(3) = "Lk" arrBooks(4) = "Jn" arrBooks(5) = "Ac" arrBooks(6) = "Rom" arrBooks(7) = "1 Co" arrBooks(8) = "2 Co" arrBooks(9) = "Gal" arrBooks(10) = "Eph" arrBooks(11) = "Ph" arrBooks(12) = "Col" arrBooks(13) = "1 Th" arrBooks(14) = "2 Th" arrBooks(15) = "1 Ti" arrBooks(16) = "2 Ti" arrBooks(17) = "Tit" arrBooks(18) = "Pm" arrOnlyOne(18) = True arrBooks(19) = "Heb" arrBooks(20) = "Jas" arrBooks(21) = "1 Pe" arrBooks(22) = "2 Pe" arrBooks(23) = "1 Jn" arrBooks(24) = "2 Jn" arrBooks(25) = "3 Jn" arrBooks(26) = "Ju" arrOnlyOne(26) = True arrBooks(27) = "Rev" strFullBooks = ",Matthew,Mark,Luke,John,Acts,Romans,1 Corinthians,2 Corinthians,Galatians,Ephesians,Philippians,Colossians,1 Thessalonians,2 Thessalonians,1 Timothy,2 Timothy,Titus,Philemon,Hebrews,James,1 Peter,2 Peter,1 John,2 John,3 John,Jude,Revelation" arrFullBooks = Split(strFullBooks, ",") ReDim arrVerseList(1 To 1) intXRef = 0 blnStarted = False For intJidx = 1 To 27 blnOnlyOne = arrOnlyOne(intJidx) intXRef = 0 StatusBar = "Searching for references to " & arrFullBooks(intJidx) strFindText = arrBooks(intJidx) & ". ([0-9]{1,2})" For Each myRange In ActiveDocument.StoryRanges Set fRange = myRange With myRange.Find .ClearFormatting .Text = strFindText .Replacement.Text = "" .Forward = True .Wrap = wdFindStop .Format = False .MatchCase = True .MatchWholeWord = False .MatchWildcards = True .MatchSoundsLike = False .MatchAllWordForms = False Do While .Execute intTotalRefs = intTotalRefs + 1 With fRange .End = .Start + Len(strFindText) + 7 intPageNo = .Information(wdActiveEndPageNumber) strFoundText = .Text .End = .Start + 3 .Start = .End strStory = .StoryType End With ExtractRef strFoundText, strVerse, blnOnlyOne If strVerse > "" Then blnInList = False For intK = 1 To intXRef If strVerse = arrVerseList(intK) Then blnInList = True If InStr(arrVersePages(intK), Str(intPageNo)) = 0 Then arrVersePages(intK) = arrVersePages(intK) & "," & Str(intPageNo) End If Exit For End If Next intK If blnInList = False Then intXRef = intXRef + 1 ReDim Preserve arrVerseList(1 To intXRef) ReDim Preserve arrVersePages(1 To intXRef) ReDim Preserve intPages(1 To intXRef) arrVerseList(intXRef) = strVerse arrVersePages(intXRef) = Str(intPageNo) End If End If Loop End With Next myRange For intK = 1 To intXRef - 1 strVerse = arrVerseList(intK) strPages = arrVersePages(intK) intL = intK For intJ = intK + 1 To intXRef If arrVerseList(intJ) < strVerse Then strVerse = arrVerseList(intJ) strPages = arrVersePages(intJ) intL = intJ End If Next intJ arrVerseList(intL) = arrVerseList(intK) arrVersePages(intL) = arrVersePages(intK) arrVerseList(intK) = strVerse arrVersePages(intK) = strPages Next intK If arrVerseList(1) > "" Then StatusBar = "Generating index for " & arrFullBooks(intJidx) Selection.EndKey Unit:=wdStory If ActiveWindow.ActivePane.View.Type = wdPrintView Or ActiveWindow. _ ActivePane.View.Type = wdWebView Or ActiveWindow.ActivePane.View.Type = _ wdPrintPreview Then ActiveWindow.View.SeekView = wdSeekMainDocument Else ActiveWindow.Panes(2).Close End If If blnStarted = False Then Selection.TypeText Text:=vbNewLine & Chr(12) & "Index of biblical references" & vbNewLine & vbNewLine If ActiveWindow.View.SplitSpecial <> wdPaneNone Then ActiveWindow.Panes(2).Close End If If ActiveWindow.ActivePane.View.Type <> wdPrintView Then ActiveWindow.ActivePane.View.Type = wdPrintView End If ActiveDocument.Range(Start:=Selection.Start, End:=Selection.Start). _ InsertBreak Type:=wdSectionBreakContinuous Selection.Start = Selection.Start + 1 With ActiveDocument.Range(Start:=Selection.Start, End:=ActiveDocument. _ Content.End).PageSetup.TextColumns .SetCount NumColumns:=3 .EvenlySpaced = True .LineBetween = True .Width = CentimetersToPoints(4.05) .Spacing = CentimetersToPoints(1.25) End With blnStarted = True End If Selection.Style = ActiveDocument.Styles("Heading 3") Selection.TypeText Text:=arrFullBooks(intJidx) & vbNewLine Selection.Style = ActiveDocument.Styles("Normal") For intK = 1 To intXRef strVerse = arrVerseList(intK) If Mid(strVerse, 7, 6) = "888888" Then If Left(strVerse, 3) = " 0" Then strVerse = Trim(Mid(strVerse, 4, 3)) Else strVerse = Trim(Left(strVerse, 3)) & ":" & Trim(Mid(strVerse, 4, 3)) End If Else If Left(strVerse, 3) = " 0" Then strVerse1 = Trim(Mid(strVerse, 4, 3)) & "-" Else strVerse1 = Trim(Left(strVerse, 3)) & ":" & Trim(Mid(strVerse, 4, 3)) & "-" End If intChapter2 = 888 - Val(Mid(strVerse, 7, 3)) intChapter1 = Val(Left(strVerse, 3)) intVerse = 888 - Val(Right(strVerse, 3)) If intChapter2 > intChapter1 Then strVerse1 = strVerse1 & Trim(Str(intChapter2)) & ":" strVerse1 = strVerse1 & Trim(Str(intVerse)) strVerse = strVerse1 End If strVersePages = arrVersePages(intK) BibleSort strVersePages Selection.TypeText Text:=strVerse & vbTab & strVersePages & vbNewLine Next intK Selection.TypeText Text:=vbNewLine intXRef = 0 ReDim arrVerseList(1 To 1) ReDim arrVersePages(1 To 1) ReDim intPages(1 To 1) End If Next intJidx MsgBox intTotalRefs & " biblical references found" End Sub Sub BibleSort(strVersePages) Dim arrSorted() As String Dim arrInteger() As Integer Dim strItem As String Dim intJ, intK, intL As Integer Dim intLimit As Integer arrSorted = Split(strVersePages, ",") intLimit = UBound(arrSorted) ReDim arrInteger(intLimit) For intK = 0 To intLimit arrInteger(intK) = Val(arrSorted(intK)) Next intK For intK = 0 To intLimit - 1 intItem = arrInteger(intK) intL = intK For intJ = intK + 1 To intLimit If arrInteger(intJ) < intItem Then intItem = arrInteger(intJ) intL = intJ End If Next intJ arrInteger(intL) = arrInteger(intK) arrInteger(intK) = intItem Next intK For intK = 0 To intLimit arrSorted(intK) = Str(arrInteger(intK)) Next intK strVersePages = Join(arrSorted, ",") End Sub Sub ExtractRef(strOrig, strNew, blnOnlyOne) Dim arrOrig() As String Dim intDebug As Boolean Dim arrVerses() As String Dim arrVerses2() As String Dim strChapter1, strChapter2, strVerse1, strVerse2 As String Dim intI, intOKCancel As Integer arrOrig = Split(strOrig, ".") intI = 2 Do While IsNumeric(Mid(arrOrig(1), intI, 1)) Or Mid(arrOrig(1), intI, 1) = "-" Or Mid(arrOrig(1), intI, 1) = ":" intI = intI + 1 Loop intI = intI - 2 arrOrig(1) = Mid(arrOrig(1), 2, intI) arrVerses = Split(arrOrig(1), "-") strChapter1 = Split(arrVerses(0), ":")(0) If InStr(arrVerses(0), ":") = 0 Then strVerse1 = strChapter1 strChapter1 = "0" If blnOnlyOne = False Then strNew = "" Exit Sub End If Else strVerse1 = Split(arrVerses(0), ":")(1) End If If InStr(arrOrig(1), "-") > 0 Then arrVerses2 = Split(arrVerses(1), ":") If InStr(arrVerses(1), ":") > 0 Then If arrVerses2(1) <> " " Then strChapter2 = arrVerses2(0) strVerse2 = arrVerses2(1) Else strVerse2 = arrVerses2(0) strChapter2 = strChapter1 End If intI = 1 Do While Mid(strVerse2, intI, 1) >= "0" And Mid(strVerse2, intI, 1) <= "9" intI = intI + 1 Loop intI = intI - 1 strVerse2 = Left(strVerse2, intI) intI = 1 Do While Mid(strVerse1, intI, 1) >= "0" And Mid(strVerse1, intI, 1) <= "9" intI = intI + 1 Loop intI = intI - 1 strVerse1 = Left(strVerse1, intI) Else strVerse2 = arrVerses2(0) strChapter2 = strChapter1 intI = 1 Do While Mid(strVerse2, intI, 1) >= "0" And Mid(strVerse2, intI, 1) <= "9" intI = intI + 1 Loop intI = intI - 1 strVerse2 = Left(strVerse2, intI) intI = 1 Do While Mid(strVerse1, intI, 1) >= "0" And Mid(strVerse1, intI, 1) <= "9" intI = intI + 1 Loop intI = intI - 1 strVerse1 = Left(strVerse1, intI) If strVerse2 = "" Then strVerse2 = strVerse1 End If Else intI = 1 Do While Mid(strVerse1, intI, 1) >= "0" And Mid(strVerse1, intI, 1) <= "9" intI = intI + 1 Loop intI = intI - 1 strVerse1 = Left(strVerse1, intI) strVerse2 = strVerse1 strChapter2 = strChapter1 End If strChapter1 = Trim(strChapter1) strChapter2 = Trim(strChapter2) strVerse1 = Trim(strVerse1) strVerse2 = Trim(strVerse2) If strChapter1 = strChapter2 And strVerse1 = strVerse2 Then strChapter2 = "888" strVerse2 = "888" ElseIf strChapter1 = strChapter2 And strVerse2 <> strVerse1 Then strVerse2 = Trim(Str(888 - Val(strVerse2))) strChapter2 = Trim(Str(888 - Val(strChapter2))) Else strChapter2 = Trim(Str(888 - Val(strChapter2))) strVerse2 = Trim(Str(888 - Val(strVerse2))) End If Do While Len(strChapter1) < 3 strChapter1 = " " & strChapter1 Loop Do While Len(strVerse1) < 3 strVerse1 = " " & strVerse1 Loop Do While Len(strChapter2) < 3 strChapter2 = " " & strChapter2 Loop Do While Len(strVerse2) < 3 strVerse2 = " " & strVerse2 Loop strNew = strChapter1 & strVerse1 & strChapter2 & strVerse2 End Sub Grateful for any suggestions, David. Last edited by macropod; 02-24-2021 at 02:14 PM. Reason: Added code tags |
#3
|
||||
|
||||
Rather than trying to decipher your code, I've updated my own to handle footnotes and endnotes. See: https://www.msofficeforums.com/word-...ure-index.html
If you want to continue developing your own code, my updated code (which has required a substantial re-write in some respects) should give you a good idea of what's required.
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#4
|
|||
|
|||
Hi Paul,
Very many thanks for this. It makes things a lot more clear. Massively helpful! David. |
Tags |
bible, index, optimisation |
|
Similar Threads | ||||
Thread | Thread Starter | Forum | Replies | Last Post |
Macro not running | Ulodesk | Word VBA | 2 | 08-13-2019 12:46 PM |
Word and Excel running very slowly | stodrocker | Office | 0 | 01-27-2018 09:14 AM |
Word 2016 running VERY slowly when typing or editing | RSutton | Word | 0 | 02-18-2017 02:11 PM |
status bar for looping macro | patrickgh | PowerPoint | 2 | 01-23-2014 09:45 PM |
Need help on macro for looping | kilosub | Word VBA | 31 | 07-27-2011 01:37 PM |