markymids,

What if you select the section of defined words and run this revised
code:

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 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
For i = LBound(ListArray) To UBound(ListArray)
With rngstory.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = ListArray(i)
On Error GoTo Done
.Replacement.Text = Format(Left(ListArray(i), 1), "") &
Right(ListArray(i), Len(ListArray(i)) - 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 = True
.MatchWholeWord = True
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With


End Sub