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