Try the Prepare_Bible_Refs and Tabulate_Bible_Refs macros below.
The first thing to note is that the code looks for Bible book references in a specific format (e.g. Gen. for Genesis), as defined in 'StrBks'. If yours are different, you can edit the definitions in 'StrBks' to suit. The code also requires books beginning with numerals (e.g. 1 Ki.) to have a non-breaking space between the numeral and the book's (abbreviated) name. If your document doesn't already use non-breaking spaces there, you can correct that before running the macros via a wildcard Find/Replace, where:
Find = (<[1-3]) ([CJKPST][a-z]@>)
Replace = \1^s\2
This also has the advantage of ensuring book references like '1 Ki.', '2|Tim.', etc., are kept together on the same line.
The next thing to note is that the Tabulate_Bible_Refs macro, which actually builds the index table, doesn't handle the second & subsequent references in sequences like Gen. 1:1, 5; 3:7, etc. That's where the Prepare_Bible_Refs macro comes in. The Prepare_Bible_Refs turns sequences like Gen. 1:1, 5; 3:7 into Gen. 1:1, Gen. 1:5; Gen. 3:7, but with the red text formatted as hidden so it doesn't compromise the existing layout.
Finally, by default, the output is sent to a single-column table at the end of the document. If you want it to appear somewhere else, select that location and apply a bookmark named '_Bible_Refs' to it. And, if you want a multi-column layout, format that portion of your document with as many columns as you need. On Letter/A4 paper, a 3-column layout works well for this.
Although you need them, you don't need to run the MakeDupes, HideDupes, & ApplyStyle macros in the last code block below - they're called automatically as needed.
Code:
Option Explicit
Dim StrBks As String
Sub Prepare_Bible_Refs()
Application.ScreenUpdating = False
' This macro checks the body of a document for biblical verses
' and applies a custom 'Ref' character Style to them. It is
' assumed books beginning with numerals have a non-breaking
' space between the numeral and the book's (abbreviated) name.
'
' Consecutive verse refs are all fully expressed (e.g.
' Acts 1:1; 2:3, 14 becomes Acts 1:1; Acts 2:3, Acts 2:14).
' The macro then formats the added text as hidden, so it can
' be suppressed for display & print purposes.
' It is also coloured red for an added visual queue.
'
' After running the macro, you may want to remove the 'Ref' Style
' from some verses (e.g. in quoted text where the book names are
' not abbreviated) before running the tabulation macro.
StrBks = Replace(",Gen.,Ex.,Lev.,Num.,Deut.,Josh.,Judges,Ruth,1|Sam.,2|Sam.," & _
"1|Ki.,2|Ki.,1|Chr.,2|Chr.,Ezra,Neh.,Esth.,Job,Ps.,Prov.,Eccl.,Song,Is.,Jer.,Lam.," & _
"Ezek.,Dan.,Hos.,Joel,Amos,Obad.,Jonah,Mic.,Nah.,Hab.,Zeph.,Hagg.,Zech.,Mal.,Matt.," & _
"Mark,Luke,John,Acts,Rom.,1|Cor.,2|Cor.,Gal.,Eph.,Phil.,Col.,1|Thess.,2|Thess.," & _
"1|Tim.,2|Tim.,Tit.,Phlm.,Heb.,Jas.,1|Pet.,2|Pet.,1|John,2|John,3|John,Jude,Rev.,", "|", Chr(160))
Dim Doc As Document, FNt As Footnote, ENt As Endnote
Set Doc = ActiveDocument
' Add the 'Ref' Style if not already present
On Error Resume Next
Doc.Styles.Add Name:="Ref", Type:=wdStyleTypeCharacter
On Error GoTo 0
' Duplicate book/chapter refs for repeated bible verses.
Call MakeDupes(Doc, Replace("<[1-3]^s[A-Z][a-z.]{2|5} [0-9]{1|}:[! .,;”\)]{1|}[;,]", "|", Application.International(wdListSeparator)))
Call MakeDupes(Doc, Replace("<[A-Z][a-z.]{2|5} [0-9]{1|}:[!^s .,;”\)]{1|}[;,]", "|", Application.International(wdListSeparator)))
' Apply the 'Ref' Style to all bible verses.
Call ApplyStyle(Doc, Replace("<[1-3]^s[A-Z][a-z.]{2|5} [0-9]{1|}:[!^s .,;\:”'’\)]{1|}", "|", Application.International(wdListSeparator)))
Call ApplyStyle(Doc, Replace("<[A-Z][a-z.]{2|5} [0-9]{1|}:[! .,;\:”'’\)]{1|}", "|", Application.International(wdListSeparator)))
' Hide book/chapter refs for repeated bible verses.
Call HideDupes(Doc, Replace("(<[1-3]^s[A-Z][a-z.]{2|5}) [0-9]{1|}:[!^s .,;”\)]{1|}[;,] \1", "|", Application.International(wdListSeparator)))
Call HideDupes(Doc, Replace("(<[A-Z][a-z.]{2|5}) [0-9]{1|}:[!^s .,;”\)]{1|}[;,] \1", "|", Application.International(wdListSeparator)))
' Repair footnote & endnote references
For Each FNt In Doc.Footnotes
FNt.Reference.Style = "Footnote Reference"
Next
For Each ENt In Doc.Endnotes
ENt.Reference.Style = "Endnote Reference"
Next
End Sub
Code:
Sub Tabulate_Bible_Refs()
Application.ScreenUpdating = False
' This macro checks the body of a document for biblical verses
' formatted in the custom 'Ref' character Style. These refs are
' then tallied and their page references output to a table at the
' end of the document, showing the page #s on which they occur.
Dim Doc As Document, RngStry As Range, Rng As Range, Tbl As Table, Pg As Page, Rct As Rectangle
Dim StrTerms As String, StrFnd As String, StrPages As String, ArrPgs() As String
Dim StrOut As String, StrTmp As String, ColWdth As Single
Dim i As Long, j As Long, k As Long, p As Long, bHid As Boolean, bFnd As Boolean
Const StrBkMk As String = "_Bible_Refs"
ColWdth = CentimetersToPoints(5.25)
StrPages = "": StrPages = "": StrTerms = vbCr
bHid = ActiveWindow.View.ShowHiddenText
ActiveWindow.View.ShowHiddenText = True
Set Doc = ActiveDocument
'Go through the document looking for biblical verse refs.
With Doc
'Check whether our table exists. If so, delete it.
With .Range
If .Bookmarks.Exists(StrBkMk) Then
Set Rng = .Bookmarks(StrBkMk).Range
If Rng.Tables.Count > 0 Then Rng.Tables(1).Delete
Else
Set Rng = .Characters.Last
End If
End With
.Bookmarks.Add StrBkMk, Rng
For Each RngStry In .StoryRanges
Select Case RngStry.StoryType
Case wdEndnotesStory, wdFootnotesStory, wdMainTextStory
With RngStry
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Format = True
.MatchWildcards = True
.Text = ""
.Replacement.Text = ""
.Style = "Ref"
.Wrap = wdFindStop
.MatchWildcards = True
.Execute
End With
Do While .Find.Found = True
StrTmp = .Text
' Pad small Chapter & Verse #s with leading 0s
If Split(StrTmp, " ")(0) = "Ps." Then
If Len(Split(Split(StrTmp, " ")(1), ":")(0)) = 1 Then
StrTmp = Split(StrTmp, " ")(0) & " 00" & Split(StrTmp, " ")(1)
ElseIf Len(Split(Split(StrTmp, " ")(1), ":")(0)) = 2 Then
StrTmp = Split(StrTmp, " ")(0) & " 0" & Split(StrTmp, " ")(1)
End If
If Len(Split(Split(StrTmp, ":")(1), "-")(0)) = 1 Then
StrTmp = Split(StrTmp, ":")(0) & ":0" & Split(StrTmp, ":")(1)
ElseIf Len(Split(Split(StrTmp, ":")(1), "-")(0)) = 2 Then
StrTmp = Split(StrTmp, ":")(0) & ":00" & Split(StrTmp, ":")(1)
End If
ElseIf Len(Split(Split(StrTmp, " ")(1), ":")(0)) = 1 Then
StrTmp = Split(StrTmp, " ")(0) & " 0" & Split(StrTmp, " ")(1)
End If
If Len(Split(Split(StrTmp, ":")(1), "-")(0)) = 1 Then
StrTmp = Split(StrTmp, ":")(0) & ":0" & Split(StrTmp, ":")(1)
End If
'If it's not in the StrTerms list, add it.
If InStr(StrTerms, vbCr & StrTmp & vbCr) = 0 Then StrTerms = StrTerms & StrTmp & vbCr
.Collapse wdCollapseEnd
.Find.Execute
Loop
End With
End Select
Next
'Exit if no biblical verse refs have been found.
If StrTerms = vbCr Then
MsgBox "No defined terms found." & vbCr & "Aborting.", vbExclamation, "Defined Terms Error"
GoTo ErrExit
End If
'Sort the biblical verse refs
Set Rng = .Range.Characters.Last
With Rng
.Collapse wdCollapseEnd
.InsertBefore vbCr
.InsertAfter StrTerms
.Sort ExcludeHeader:=True, FieldNumber:=1, SortFieldType:=wdSortFieldAlphanumeric, _
SortOrder:=wdSortOrderAscending
StrTerms = .Text
.Text = vbNullString
While Left(StrTerms, 1) = vbCr
StrTerms = Mid(StrTerms, 2, Len(StrTerms) - 1)
Wend
End With
'Build the page records for all biblical verse refs in the StrTerms list.
For i = 0 To UBound(Split(StrTerms, vbCr)) - 1
StrFnd = Trim(Split(StrTerms, vbCr)(i)): StrPages = " "
For Each RngStry In .StoryRanges
Select Case RngStry.StoryType
Case wdEndnotesStory, wdFootnotesStory, wdMainTextStory
With RngStry
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Format = False
.Text = Replace(Replace(Replace(Replace(StrFnd, " 0", " "), " 0", " "), ":0", ":"), ":0", ":")
.Wrap = wdFindStop
.MatchWholeWord = True
.MatchWildcards = False
.MatchCase = True
.Execute
End With
Do While .Find.Found = True
'If we haven't already found this ref on this page, add it to the list.
Doc.ActiveWindow.View.ShowHiddenText = False
Select Case RngStry.StoryType
Case wdMainTextStory
j = .Information(wdActiveEndAdjustedPageNumber)
If InStr(StrPages, " " & j & " ") = 0 Then
StrPages = StrPages & j & " "
End If
Case wdEndnotesStory
bFnd = False
For p = .Endnotes(1).Reference.Information(wdActiveEndPageNumber) To Doc.ComputeStatistics(wdStatisticPages)
Set Pg = Doc.ActiveWindow.Panes(1).Pages(p)
For Each Rct In Pg.Rectangles
If .InRange(Rct.Range) Then
j = Rct.Range.Information(wdActiveEndAdjustedPageNumber)
bFnd = True: Exit For
End If
Next
If bFnd = True Then Exit For
Next
If InStr(StrPages, " " & j & " ") = 0 Then
StrPages = StrPages & j & " "
End If
Case wdFootnotesStory
bFnd = False
For p = .Footnotes(1).Reference.Information(wdActiveEndPageNumber) To Doc.ComputeStatistics(wdStatisticPages)
Set Pg = Doc.ActiveWindow.Panes(1).Pages(p)
For Each Rct In Pg.Rectangles
If .InRange(Rct.Range) Then
j = Rct.Range.Information(wdActiveEndAdjustedPageNumber)
bFnd = True: Exit For
End If
Next
If bFnd = True Then Exit For
Next
If InStr(StrPages, " " & j & " ") = 0 Then
StrPages = StrPages & j & " "
End If
End Select
Doc.ActiveWindow.View.ShowHiddenText = True
.Find.Execute
Loop
End With
End Select
Next
If StrPages <> " " Then
ArrPgs() = Split(Trim(StrPages), " ")
WordBasic.SortArray ArrPgs()
'Add the current record to the output list (StrOut)
StrOut = StrOut & StrFnd & vbTab & Join(ArrPgs(), ", ") & vbCr
End If
Next
With .Range
If .Bookmarks.Exists(StrBkMk) Then Set Rng = .Bookmarks(StrBkMk).Range
End With
'Output the found biblical verse refs as a table at the end of the document.
With Rng
'Calculate the number of table lines for the data.
j = UBound(Split(StrOut, vbCr))
Set Tbl = .Tables.Add(Range:=.Duplicate, NumRows:=j + 1, NumColumns:=1)
With Tbl
.AllowAutoFit = False
.LeftPadding = 0
.RightPadding = 0
'Define the overall table layout.
With .Range.ParagraphFormat
.Style = wdStyleNormal
.RightIndent = 0
With .TabStops
.ClearAll
.Add Position:=ColWdth, Alignment:=wdAlignTabRight, Leader:=wdTabLeaderDots
End With
.SpaceBefore = 0
.SpaceAfter = 0
End With
'Populate & format the header row.
With .Cell(1, 1).Range
.Text = "Passage" & vbTab & "Pages"
.ParagraphFormat.KeepWithNext = True
End With
With .Rows.First
'Apply the heading row attribute so that the table header repeats after a page break.
.HeadingFormat = True
'Delete the header row's tab leaders.
With .Range
With .ParagraphFormat.TabStops
.ClearAll
.Add Position:=ColWdth, Alignment:=wdAlignTabRight, Leader:=wdTabLeaderSpaces
End With
.Font.Bold = True
End With
End With
For i = 0 To j - 1
' Populate the data rows
.Cell(i + 2, 1).Range.Text = Split(StrOut, vbCr)(i)
Next
.Columns.Add .Columns(1)
' Bookmark the table.
Doc.Bookmarks.Add Name:=StrBkMk, Range:=Tbl.Range
StrFnd = "": k = 0
For i = 2 To .Rows.Count
StrTmp = Split(.Cell(i, 2).Range.Text, " ")(0)
If StrFnd <> StrTmp Then
For j = 1 To UBound(Split(StrBks, ",")) - 1
If Split(StrBks, ",")(j) = StrTmp Then
StrFnd = StrTmp: k = j: Exit For
End If
Next
End If
.Cell(i, 1).Range.Text = j
Next
' Sort the table
.Sort ExcludeHeader:=True, FieldNumber:=1, SortFieldType:=wdSortFieldNumeric, SortOrder:=wdSortOrderAscending
j = CLng(Split(.Cell(.Rows.Count, 1).Range.Text, vbCr)(0))
For i = .Rows.Count To 2 Step -1
If j <> CLng(Split(.Cell(i, 1).Range.Text, vbCr)(0)) Then
j = CLng(Split(.Cell(i, 1).Range.Text, vbCr)(0))
.Rows.Add .Rows(i + 1)
End If
Next
.Columns(1).Delete
' Delete leading 0s from small Chapter & Verse #s
With .Range.Find
.MatchWildcards = True
.Text = Replace("([ :])[0]{1|2}", "|", Application.International(wdListSeparator))
.Replacement.Text = "\1"
.Wrap = wdFindStop
.Execute Replace:=wdReplaceAll
End With
' Finalize table formatting
.PreferredWidthType = wdPreferredWidthPoints
.PreferredWidth = ColWdth
.Rows.Alignment = wdAlignRowCenter
End With
End With
End With
'Clean up and exit.
ErrExit:
Set RngStry = Nothing: Set Rct = Nothing: Set Rng = Nothing: Set Tbl = Nothing: Set Doc = Nothing
ActiveWindow.View.ShowHiddenText = bHid
Application.ScreenUpdating = True
End Sub
Code:
Sub MakeDupes(Doc As Document, StrFnd As String)
Dim RngStry As Range, Rng As Range, StrBk As String, StrCh As String
For Each RngStry In Doc.StoryRanges
Select Case RngStry.StoryType
Case wdEndnotesStory, wdFootnotesStory, wdMainTextStory
With RngStry
With .Find
.ClearFormatting
.Wrap = wdFindStop
.MatchWildcards = True
.Text = StrFnd
.Execute
End With
Do While .Find.Found = True
Set Rng = .Duplicate.Words.First
With Rng
If .Characters.Last <> " " Then
.MoveEndUntil " ", wdForward
.End = .End + 1
End If
StrBk = .Text
.Collapse wdCollapseEnd
.MoveEndUntil ":", wdForward
.End = .End + 1
StrCh = .Text
End With
Set Rng = .Duplicate.Characters.Last
With Rng
.End = .End + 2
If .Characters.Last Like "[0-9]" Then
.MoveEndWhile "[0-9]", wdForward
If Not .Characters.Last.Next Like "[ A-Za-z]" Then
If .Characters.First = "," Then
.Characters(2).InsertAfter StrBk & StrCh
Else
.Characters(2).InsertAfter StrBk
End If
End If
End If
End With
.Collapse wdCollapseStart
.Start = .Words.First.End
.Find.Execute
Loop
End With
End Select
Next
End Sub
Sub ApplyStyle(Doc As Document, StrFnd As String)
Dim RngStry As Range
For Each RngStry In Doc.StoryRanges
Select Case RngStry.StoryType
Case wdEndnotesStory, wdFootnotesStory, wdMainTextStory
With RngStry
With .Find
.ClearFormatting
.Wrap = wdFindStop
.MatchWildcards = True
.Text = StrFnd
.Execute
End With
Do While .Find.Found = True
If InStr(StrBks, "," & Split(.Text, " ")(0) & ",") > 0 Then .Style = "Ref"
.Collapse wdCollapseEnd
.Find.Execute
Loop
End With
End Select
Next
End Sub
Sub HideDupes(Doc As Document, StrFnd As String)
Dim RngStry As Range, Rng As Range, StrBk As String, StrCh As String, i As Long
For Each RngStry In Doc.StoryRanges
Select Case RngStry.StoryType
Case wdEndnotesStory, wdFootnotesStory, wdMainTextStory
With RngStry
With .Find
.ClearFormatting
.Wrap = wdFindStop
.MatchWildcards = True
.Text = StrFnd
.Execute
End With
Do While .Find.Found = True
Set Rng = .Duplicate.Words.First
With Rng
If .Characters.Last <> " " Then
.MoveEndUntil " ", wdForward
.End = .End + 1
End If
StrBk = .Text
.Collapse wdCollapseEnd
.MoveEndUntil ":", wdForward
.End = .End + 1
StrCh = .Text
.Collapse wdCollapseEnd
.MoveStartUntil StrBk, wdForward
.Start = .Start + 1
.End = .Start + Len(StrBk)
.Font.Hidden = True
.Font.ColorIndex = wdRed
With .Duplicate
.Collapse wdCollapseEnd
.End = .Start + Len(StrCh)
If .Text = StrCh Then
.Font.Hidden = True
.Font.ColorIndex = wdRed
End If
End With
End With
.Collapse wdCollapseStart
.Start = .Words.First.End
.Find.Execute
Loop
End With
End Select
Next
End Sub
Note: Ideally, one would declare & populate 'StrBks' as a constant. Due to the limitations of the board software, though, non-breaking spaces are not properly reproduced here. Accordingly, I've had to address their usage in a different way in the code. As the code uses Word's wildcard Find/Replace function, it's also slightly more complicated than it might otherwise need to be so as to deal with any internationalisation issues.
For PC macro installation & usage instructions, see: Installing Macros
For Mac macro installation & usage instructions, see: Word:mac - Install a Macro
__________________
Cheers,
Paul Edstein
[Fmr MS MVP - Word]
|