Microsoft Office Forums

Go Back   Microsoft Office Forums > >

Reply
 
Thread Tools Display Modes
  #1  
Old 02-23-2021, 03:46 PM
VBAFiddler VBAFiddler is offline Macro running very slowly, and possibly looping Windows 10 Macro running very slowly, and possibly looping Office 2016
Novice
Macro running very slowly, and possibly looping
 
Join Date: Feb 2021
Posts: 14
VBAFiddler is on a distinguished road
Post 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
Reply With Quote
  #2  
Old 02-24-2021, 09:36 AM
VBAFiddler VBAFiddler is offline Macro running very slowly, and possibly looping Windows 10 Macro running very slowly, and possibly looping Office 2016
Novice
Macro running very slowly, and possibly looping
 
Join Date: Feb 2021
Posts: 14
VBAFiddler is on a distinguished road
Post 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
Did I misunderstand how stories work.
Grateful for any suggestions,
David.

Last edited by macropod; 02-24-2021 at 02:14 PM. Reason: Added code tags
Reply With Quote
  #3  
Old 03-04-2021, 09:47 PM
macropod's Avatar
macropod macropod is online now Macro running very slowly, and possibly looping Windows 10 Macro running very slowly, and possibly looping Office 2016
Administrator
 
Join Date: Dec 2010
Location: Canberra, Australia
Posts: 21,956
macropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond repute
Default

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]
Reply With Quote
  #4  
Old 03-05-2021, 04:33 AM
VBAFiddler VBAFiddler is offline Macro running very slowly, and possibly looping Windows 10 Macro running very slowly, and possibly looping Office 2016
Novice
Macro running very slowly, and possibly looping
 
Join Date: Feb 2021
Posts: 14
VBAFiddler is on a distinguished road
Lightbulb

Hi Paul,

Very many thanks for this. It makes things a lot more clear.
Massively helpful!
David.
Reply With Quote
Reply

Tags
bible, index, optimisation

Thread Tools
Display Modes


Similar Threads
Thread Thread Starter Forum Replies Last Post
Macro running very slowly, and possibly looping 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
Macro running very slowly, and possibly looping Need help on macro for looping kilosub Word VBA 31 07-27-2011 01:37 PM

Other Forums: Access Forums

All times are GMT -7. The time now is 06:03 AM.


Powered by vBulletin® Version 3.8.11
Copyright ©2000 - 2024, vBulletin Solutions Inc.
Search Engine Optimisation provided by DragonByte SEO (Lite) - vBulletin Mods & Addons Copyright © 2024 DragonByte Technologies Ltd.
MSOfficeForums.com is not affiliated with Microsoft