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
|