Macro running very slowly, and possibly looping

[VBAFiddler]

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.

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