OK. This one will build the array consisting of "BOLD" words and
exludes BOLD words in your selection. Only select the list of
definitions (why are there other bold words in the list?).

Would it be a big job for the code to tell you (via a message box) how
how
many replacements it had made in the document?

For me yes. I believe it could be done. Instead of using:
..Execute Replace:=wdReplaceAll

You would need to something Like Do While .Execute

replace.text
sequence a
counter
collapse
the range
Loop
MsgBox "Report count"

It would slow things down and I can't get my head around it at present.
Check out my website:

http://gregmaxey.mvps.org/word_tips.htm
and the helpful links contain therein :-)

Option Explicit
Public Sub MultiWordFindReplace()

Dim rngstory As Word.Range
Dim ListArray
Dim oWord As Range

'Create the array by selecting the list of definitions
For Each oWord In Selection.Words
If oWord.Font.Bold = True And Asc(oWord.Next) = 34 Then
ListArray = ListArray & oWord & " "
End If
Next oWord

ListArray = Split(ListArray)

'Fix the skipped blank Header/Footer problem
MakeHFValid
'Iterate through all story types in the current document
For Each rngstory In ActiveDocument.StoryRanges
'Iterate through all linked stories
Do
SearchAndReplaceInStory rngstory, ListArray
' Get next linked story (if any)
Set rngstory = rngstory.NextStoryRange
Loop Until rngstory Is Nothing
Next
End Sub
Public Sub SearchAndReplaceInStory(ByVal rngstory As Word.Range, ByRef
ListArray As Variant)
ResetFRParameters
Dim i As Long
Dim myString As String
For i = LBound(ListArray) To UBound(ListArray)
'Strip the "speech marks" from the find text
myString = ListArray(i)
With rngstory.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = myString
On Error GoTo Done
.Replacement.Text = Format(Left(myString, 1), "") &
Right(myString, Len(myString) - 1)
.Replacement.Font.Bold = True
.Execute Replace:=wdReplaceAll
End With
Next i
Done:
End Sub
Public Sub MakeHFValid()
Dim lngJunk As Long
lngJunk = ActiveDocument.Sections(1).Headers(1).Range.StoryT ype
End Sub
Sub ResetFRParameters()
With Selection.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = ""
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = True
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
End Sub