markymids,

I went looking for improvements to the code I sent earlier and got some
assistance from G.G. Yagoda in the VBA group. The code below is designed
for what G.G. calls a pretty standard legal document. With a section of
definitions that are quoted and bold. His sample also contains multiword
phrases with constitute a term. I have further adapted the code G.G. and I
passe back and forth. See if this meets your needs:

Public Sub WordMarker()
'Developed by Greg Maxey with input and assistance by G.G. Yagota

Dim rngstory As Word.Range
Dim ListArray
Dim j As Integer
Dim myRange As Range
Dim UserQuotePreference As Boolean
Dim QuotesToggled As Boolean

'Stores users AutoCorrect quotes options
UserQuotePreference = Options.AutoFormatAsYouTypeReplaceQuotes

Set myRange = ActiveDocument.Range
j = 0
QuotesToggled = False

'Replace curly quotes with straight quotes!!!
If MsgBox("You must convert curly quotes for this operation." _
& " Curly quotes will be restored while processing. " _
& " Are curly vice straight quotes used to bracket" _
& " defined phrases?", vbYesNo) = vbYes Then
Options.AutoFormatAsYouTypeReplaceQuotes = False
QuotesToggled = True
For Each rngstory In ActiveDocument.StoryRanges
Do
If rngstory.StoryLength = 2 Then
CurlyQuoteToggle rngstory
End If
Set rngstory = rngstory.NextStoryRange
Loop Until rngstory Is Nothing
Next
End If
Do
With myRange.Find
'Each defined word must be preceeded by a paragraph mark.
'Find phrases and build phrase list
.Text = Chr(13) & """*"""
.MatchWildcards = True
.Execute
If myRange.Font.Bold Then
myRange.Start = myRange.Start + 2
myRange.End = myRange.End - 1
Select Case myRange.Text
Case Is ""
myRange.Text = Trim(myRange.Text)
ListArray = ListArray & myRange.Text & "|"
j = j + 1
End Select
End If
myRange.End = myRange.End + 1
myRange.Start = myRange.End
End With
Loop While myRange.Find.Found
ListArray = Left(ListArray, Len(ListArray) - 1)
'Establish array
ListArray = Split(ListArray, "|")
MsgBox ("Document contains " & j & " definded terms/phrases")
MakeHFValid
Application.ScreenUpdating = False
For Each rngstory In ActiveDocument.StoryRanges
Do
If rngstory.StoryLength = 2 Then
SearchAndReplaceInStory rngstory, ListArray
End If
Set rngstory = rngstory.NextStoryRange
Loop Until rngstory Is Nothing
Next
'Reapply curly quotes
If QuotesToggled = True Then
Options.AutoFormatAsYouTypeReplaceQuotes = True
For Each rngstory In ActiveDocument.StoryRanges
Do
If rngstory.StoryLength = 2 Then
CurlyQuoteToggle rngstory
End If
Set rngstory = rngstory.NextStoryRange
Loop Until rngstory Is Nothing
Next
Options.AutoFormatAsYouTypeReplaceQuotes = UserQuotePreference
End If
Application.ScreenUpdating = True
Application.ScreenRefresh
End Sub
Public Sub SearchAndReplaceInStory(ByVal rngstory As Word.Range, ByRef
ListArray As Variant)
Dim i As Long

For i = LBound(ListArray) To UBound(ListArray)
With rngstory.Find
.ClearFormatting
.Replacement.ClearFormatting
.MatchWildcards = False
.MatchWholeWord = True
.Text = ListArray(i)
.Replacement.Text = ListArray(i)
.Replacement.Font.Bold = True
.Execute Replace:=wdReplaceAll
End With
Next i
End Sub
Public Sub MakeHFValid()
Dim lngJunk As Long
lngJunk = ActiveDocument.Sections(1).Headers(1).Range.StoryT ype
End Sub
Sub CurlyQuoteToggle(ByVal rngstory As Word.Range)
With rngstory.Find
.Text = Chr$(34)
.Replacement.Text = Chr$(34)
.Wrap = wdFindContinue
.Forward = True
.Format = False
.MatchCase = False
.MatchWildcards = False
.Execute Replace:=wdReplaceAll
End With
End Sub

--
Greg Maxey/Word MVP
See:
http://gregmaxey.mvps.org/word_tips.htm
For some helpful tips using Word.

markymids wrote:
Thanks again Greg, that is much better, we sometimes have very long
definitions and other words within a definition can be emboldened
(aswell as the definition itself).

The only thing which will stop me implementing this now is that it
changes non-exact words.

For example if I had a definition of "Lease" and ran the macro it
would also change all occurrences of "leasehold" to "Leasehold" as
well as changing "lease" to "Lease" which we wouldn't want.

However I shall look over your site and see if I can think of a way to
overcome this problem myself.

Thanks once again for all your brilliant help, I really appreciate it


"Greg" wrote:

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