Chuck,

I am unable to get your code to work.  First an error is generated here
in SearchAndReplaceInStory routine if one of the defined terms is
matched in a header or footer:

       .MoveEnd unit:=wdCharacter, _
           Count:=fldIndexEntry.Code.Characters.Count + 2

If I remove the matching term the code runs to completion but the
indexing and marking is inconsistent.

I haven't had time to disect everything you have discussed, but it is
not working with sample of text I am using.

Thanks for all that work, Greg.  Great stuff with the array sorting etc.  
I've found a couple of issues and am testing them out, will get back to you
tomorrow ok?

Hi Greg and GG

Regarding rights on the program we’ve developed, I vote for making it
available under the GPL (General Public License) which is standard in the
open source world.  Here’s a link to a copy of the GPL
(http://www.gnu.org/licenses/gpl.txt) and a link to information about the GPL
(http://www.gnu.org/copyleft/).  

Now to the code:

I added a bit of error handling – if there are no defined terms, the sub
restores curly quotes (if applicable) and exits with a message.

I removed the line
  ActiveDocument.Bookmarks("\startofdoc").Select
because it’s not necessary for a range.find especially with wrap set to
wdFindContinue.

I also removed the On Error Resume Next – my personal preference is to test
for errors and resolve them specifically.  In my experience On Error Resume
Next can mask bugs by skipping over them.  Also, I've had trouble with
programs that cause problems by generating errors then resolving them, rather
than testing for situations that cause errors and avoiding them.  I tend to
use error handling to identify bugs and flag problems rather than as a
decision processing function.

The following lines need to run before "If myRange.Font.Bold Then"
  myRange.Start = myRange.Start + 1
  myRange.End = myRange.End – 1
because quotes around defined terms may or may not be bolded themselves.  
What matters is that the defined term itself is bolded and surrounded by
quotes (regardless of whether the quotes are bolded).  I’ve tested the code
with those lines before the if-bold test and it works fine.

I’ve replaced the curly quotes restore code with the code I suggested to
restore curly quotes (in a separate macro) -- if curly quotes were initially
enabled, and then to change curly quotes in fields to straight quotes.  I
also replaced all instances of "CurlyQuote" with "SmartQuote" for consistency
sake.

I ran into endless loops with the new SearchAndReplaceInStory code – it
turns out that collapsing rngstory to end meant that the next search
iteration picked up the search string in the index entry itself.  I've added
code that counts the characters in the index entry and moves the end of
rngstory that many characters (plus 2 to account for the extra 2 spaces on
either side of the field code), then collapses to end, to get past the index
entry and that doesn’t loop.  In addition, I had to move the line that
colours the found text to BlueGray so that the term and its index entry are
both coloured BlueGray to avoid having shorter defined terms that might be
contained in the index entry field code picked up as defined terms rather
than index entry code (which was happening without the line position change).

Another endless loop occurred if a defined term was in the TOC.  I've added
code in SearchAndReplaceInStory to toggle the TOC fields to ShowCodes = True
before the search and replace, then toggle them back to False when search and
replace completes.

One problem that needs to be avoided is running the program on a document
more than once – the defined terms and their index entries will not be
coloured BlueGray so they'll all be reindexed.  The program needs to remove
previous index entries before re-indexing.  I've added switch text to the
index entry field code to specify that the entry belongs to the
"DefinedTermsIndex" as well as code that strips out the "DefinedTermsIndex"
entries before moving on to indexing.  The defined terms index field itself
will have to include the switch  \ f “DefinedTermsIndex” .

Lastly I renamed just about all the variables to make naming consistent (fld
for Field, rng for Range, str for String, etc).

Rather than trying to copy and paste individual changes you might want to
copy the whole shebang.  Looking forward to comments.

Option Explicit

Public Sub WordMarkerWithIndexer()
'Developed by Greg Maxey, G. G. Yagoda and Chuck Henrich

Dim rngStory As Word.Range
Dim arrListArray
Dim rngRange As Range
Dim blnEnableSmartQuotes As Boolean
Dim fldField As Field

StripPreviousIndexing

'Stores users AutoCorrect "smart quote" _
'options.  True if enabled
blnEnableSmartQuotes = Options.AutoFormatAsYouTypeReplaceQuotes

'Hide XE Field text while processing
ActiveWindow.View.ShowHiddenText = False

'Convert curly quotes if used
Options.AutoFormatAsYouTypeReplaceQuotes = False

'Return to start of MainTextStory
For Each rngStory In ActiveDocument.StoryRanges
 Do
   If rngStory.StoryLength >= 2 Then
     SmartQuoteToggle rngStory
   End If
   Set rngStory = rngStory.NextStoryRange
 Loop Until rngStory Is Nothing
Next
 
'Build Defined Terms list and create array
Set rngRange = ActiveDocument.Range
Do
With rngRange.Find
  'Find Defined Terms
  '(terms quoted and in bold text)
  .Text = """*"""
  .MatchWildcards = True
  .Execute
  rngRange.Start = rngRange.Start + 1
  rngRange.End = rngRange.End - 1
  If rngRange.Font.Bold Then
    'Elimate zero length strings and
    'erroneous white space
    Select Case rngRange.Text
      Case Is <> ""
        rngRange.Text = Trim(rngRange.Text)
        'Add to list
        arrListArray = arrListArray & rngRange.Text & "|"
    End Select
  End If
  'Step range past last found quotation mark
  rngRange.End = rngRange.End + 1
  rngRange.Collapse wdCollapseEnd
End With
Loop While rngRange.Find.Found

'If no defined terms then
'restore curly quotes (if applicable)
'and exit
If arrListArray = "" Then
   MsgBox "There are no defined terms " & _
           "in this document."
   RestoreSmartQuotes (blnEnableSmartQuotes)
   Exit Sub
End If

'Clip trailing separator character
arrListArray = Left(arrListArray, Len(arrListArray) - 1)

'Define the array
arrListArray = Split(arrListArray, "|")

'Call sort function to sort array
'longest term to shortest term
arrListArray = ListSort(arrListArray)

MsgBox ("Document contains " & _
        UBound(arrListArray) + 1 & _
        " defined terms")

'Validate blank headers and footers
MakeHFValid

RestoreSmartQuotes (blnEnableSmartQuotes)

'Main routine
Application.ScreenUpdating = False
For Each rngStory In ActiveDocument.StoryRanges
Do
  If rngStory.StoryLength >= 2 Then
    SearchAndReplaceInStory rngStory, arrListArray
  End If
  Set rngStory = rngStory.NextStoryRange
Loop Until rngStory Is Nothing
Next

'Clear bold in TOC entries
For Each fldField In ActiveDocument.Fields
 If fldField.Type = wdFieldTOC Then
   fldField.Result.Font.Bold = False
   Exit For
 End If
Next

RestoreTextColor

Application.ScreenUpdating = True
'ActiveWindow.View.ShowHiddenText = True
Selection.HomeKey unit:=wdStory

MsgBox "Defined terms have been indexed.", vbOKOnly, "Done"

End Sub

Public Sub SearchAndReplaceInStory( _
           ByVal rngStory As Word.Range, _
           ByRef arrListArray As Variant)

Dim i As Long
Dim fldIndexEntry As Field
Dim fldField As Field

'Show field codes for TOC
'to prevent looping
For Each fldField In ActiveDocument.Fields
   If fldField.Type = 13 Then '13 = TOC
       fldField.ShowCodes = True
   End If
Next fldField

For i = LBound(arrListArray) To UBound(arrListArray)
 Selection.HomeKey unit:=wdStory
 With rngStory.Find
   .ClearFormatting
   .Replacement.ClearFormatting
   .MatchCase = True
   .MatchWholeWord = False
   .MatchWildcards = False
   .MatchSoundsLike = False
   .MatchAllWordForms = False
   .Wrap = wdFindStop
   .Text = arrListArray(i)
    While .Execute
      With rngStory

       If .Font.Color <> wdColorBlueGray Then
         .Text = .Text
         .Font.Bold = True
         Set fldIndexEntry = _
            ActiveDocument.Indexes.MarkEntry _
            (Range:=rngStory, _
            Entry:=Trim(arrListArray(i)))
         fldIndexEntry.Code.Text = _
           fldIndexEntry.Code.Text & "\f ""DefinedTermsIndex"" "
       End If
       .MoveEnd unit:=wdCharacter, _
           Count:=fldIndexEntry.Code.Characters.Count + 2
       .Font.Color = wdColorBlueGray
       .Collapse Direction:=wdCollapseEnd
       .Select
      End With
   Wend
 End With
 rngStory.Expand unit:=wdStory
Next i

'Show field codes for TOC
'to prevent looping
For Each fldField In ActiveDocument.Fields
   If fldField.Type = 13 Then '13 = TOC
       fldField.ShowCodes = False
   End If
Next fldField

End Sub

Public Sub MakeHFValid()

Dim lngJunk As Long

lngJunk = ActiveDocument.Sections(1).Headers(1).Range.StoryType

End Sub

Sub SmartQuoteToggle(ByVal rngStory As Word.Range)

With rngStory.Find
  .Text = """"
  .Replacement.Text = """"
  .Forward = True
  .Wrap = wdFindContinue
  .Format = False
  .Execute Replace:=wdReplaceAll
End With

End Sub
Function ListSort(arrListArray) As Variant
'Modified from code found in Google Groups :-)

Dim i As Integer, j As Integer
Dim lngFirst As Integer, lngLast As Integer
Dim varTemp As Variant
Dim varSortedList As Variant
Dim strString As String

lngFirst = LBound(arrListArray)
lngLast = UBound(arrListArray)

ReDim varSortedList(lngLast)

For i = lngFirst To lngLast
 For j = i + 1 To lngLast
   If Len(arrListArray(i)) < Len(arrListArray(j)) Then
     varTemp = arrListArray(j)
     arrListArray(j) = arrListArray(i)
     arrListArray(i) = varTemp
   End If
 Next j
Next i

For i = lngFirst To lngLast
 varSortedList(i) = arrListArray(i)
Next i

ListSort = varSortedList
strString = Join(ListSort, "|")

End Function

Sub RestoreTextColor()

Dim rngStory As Word.Range

MakeHFValid

For Each rngStory In ActiveDocument.StoryRanges
  Do Until (rngStory Is Nothing)
     With rngStory.Find
       .ClearFormatting
       .Replacement.ClearFormatting
       .Font.Color = wdColorBlueGray
       .Replacement.Font.Color = wdColorAutomatic
       .Execute Replace:=wdReplaceAll
     End With
     Set rngStory = rngStory.NextStoryRange
   Loop
Next

End Sub

Sub RestoreSmartQuotes(ByVal blnEnableSmartQuotes)
'Restores curly quotes then replaces
'curly quotes appearing in fields with
'straight quotes

Dim rngStory As Word.Range
Dim fldField As Field

'Restore curly qoutes
If blnEnableSmartQuotes = True Then
For Each rngStory In ActiveDocument.StoryRanges
 Do
   If rngStory.StoryLength >= 2 Then
       Options.AutoFormatAsYouTypeReplaceQuotes = True
       'Call SmartQuoteToggle macro
       SmartQuoteToggle rngStory
       'Restore straight quotes in fields
       Options.AutoFormatAsYouTypeReplaceQuotes = False
       For Each fldField In ActiveDocument.Fields
         fldField.Select
         'Need selection find for fields
         'range find not available
         With Selection.Find
           .Text = """"
           .Replacement.Text = """"
           .Forward = True
           .Wrap = wdFindStop
           .Format = False
           .Execute Replace:=wdReplaceAll
         End With
         If fldField.Type = wdFieldTOC Then
           fldField.Result.Font.Bold = False
           Exit For
         End If
       Next fldField
       Options.AutoFormatAsYouTypeReplaceQuotes = True
    End If
   Set rngStory = rngStory.NextStoryRange
 Loop Until rngStory Is Nothing
Next rngStory
End If

End Sub

Sub StripPreviousIndexing()

Dim fldField As Field
Dim rngStory As Range

MakeHFValid

For Each rngStory In ActiveDocument.StoryRanges
   Do Until (rngStory Is Nothing)
  For Each fldField In rngStory.Fields
   If fldField.Type = 4 Then 'Index entry
    If Right(fldField.Code.Text, 23) = _
     "\f ""DefinedTermsIndex"" " Then
      fldField.Delete
    End If
   End If
  Next fldField
  Set rngStory = rngStory.NextStoryRange
 Loop
Next

End Sub