Greg, you are a star! That is almost working perfectly.

The only problems I can foresee with this a

1. It only Finds and replaces emboldened words, in our documents
definitions are in bold and enclosed in "quotes". Therefore when creating
the array it needs to only include those words which are in bold AND enclosed
in quotes.

However when it runs the macro it needs to remove these quotes (as
definitions in the body of the document will not be in quotes).

2. It must only find and replace exact matches only. For example if I ran
the code on a definition of "Lease" it should not find and replace the word:
leasehold for example, it should only find and replace lease (replacing it
with Lease).

Thanks again for your stellar suggestion, I am finally seeing light at the
end of the tunnel here!

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?

Regards

"Greg" wrote:

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