vba script find and highlight multi-word phrases

I use MS Word 2003. I'm trying to find and highlight words in Word docs (consisting of single words and milti-word phrases like "I think that") but can't figure out how to get the script to highlight multi-word phrases.

I tried the following two script and had the following issues:

1.
`````````````
Sub CompareWordList()
Dim sCheckDoc As String
Dim docRef As Document
Dim docCurrent As Document
Dim wrdRef As Object

sCheckDoc = "c:\checklist.doc"
Set docCurrent = Selection.Document
Set docRef = Documents.Open(sCheckDoc)
docCurrent.Activate

With Selection.Find
.ClearFormatting
.Replacement.ClearFormatting
.Replacement.Font.Bold = True
.Replacement.Text = "^&"
.Forward = True
.Format = True
.MatchWholeWord = True
.MatchCase = True
.MatchWildcards = False
End With

For Each wrdRef In docRef.Words
If Asc(Left(wrdRef, 1)) > 32 Then
With Selection.Find
.Wrap = wdFindContinue
.Text = wrdRef
.Execute Replace:=wdReplaceAll
End With
End If
Next wrdRef

docRef.Close
docCurrent.Activate
End Sub
PROBLEM: It highlights each word of my multi-word items instead of the whole thing and it highlights parts of whole words. I put all my words in my word doc seperated by spaces and quotes around the multi-word entries.

`````````````
2.
```````````````
Const wdReplaceAll = 2

Set objWord = CreateObject("Word.Application")
objWord.Visible = True

Set objDoc = objWord.Documents.Open("C:\edit.doc")
Set objSelection = objWord.Selection

arrWords = Array("I think that", "very")

For Each strWord In arrWords
objSelection.Find.Text = strWord
objSelection.Find.Forward = True
objSelection.Find.MatchWholeWord = True

objSelection.Find.Replacement.Highlight = True

objSelection.Find.Execute , , , , , , , , , , wdReplaceAll
Next

PROBLEM: It appears this script just skipped the multi-word items and didn't highlight it. It only highlighted the 2nd word.

``````````````

Whether I use a seperate file with all my words or input all the words and phrases into an array, I simply need it to recognize multi-word entries as a unit and not individual words.

Thank you for your time,
Shane

Try:

[VBA]Sub ScratchMacro()
Dim oRng As Word.Range
Dim arrWords
Dim i As Long
arrWords = Array("I think that", "very")
For i = 0 To UBound(arrWords)
Set oRng = ActiveDocument.Range
With oRng.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = arrWords(i)
.MatchWholeWord = True
.Replacement.Highlight = True
.Execute Replace:=wdReplaceAll
End With
Next
End Sub
[/VBA]

Worked like a charm Greg. Thank you kindly.

Hi,
I am new to this forum, I need help. I am not clear with the above discussion as well as the macro. Please provide me with a single macro to find the multi-word phrases. So that i can copy and pase in macro editor. It will be more useful for me.

"Please provide me with a single macro to find the multi-word phrases. So that i can copy and pase in macro editor"

You have already been provided with it. An example of it is the code Greg posted. Copy it into the VBE - Visual Basic Editor (macro editor). If it may help, I will walk you through the code.[vba]
Sub ScratchMacro()
Dim oRng As Word.Range
Dim arrWords
Dim i As Long
arrWords = Array("I think that", "very")
For i = 0 To UBound(arrWords)
Set oRng = ActiveDocument.Range
With oRng.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = arrWords(i)
.MatchWholeWord = True
.Replacement.Highlight = True
.Execute Replace:=wdReplaceAll
End With
Next
End Sub
[/vba]
1. declare the variables
[vba] Dim oRng As Word.Range
Dim arrWords
Dim i As Long [/vba]

2. give values to the array[vba]
arrWords = Array("I think that", "very") [/vba]The array arrWords is now composed of two items: "I think that" and "very". Numerically, this means:

arrWords(0) = "I think that"
arrWords(1) = "very"

Arrays are by default 0=-based.

3. for each item in the array (from 0 to the UPPER BOUND, the last...so it could 1 in this case..or 101)
[vba] For i = 0 To UBound(arrWords)
[/vba]The first one will be "I think that".

4. make a range object of the entire document[vba] Set oRng = ActiveDocument.Range
[/vba]

5. using Find, search for all instances of the array item (e.g. "I think that") and replace it with the same text, but highlighted[vba] With oRng.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = arrWords(i)
.MatchWholeWord = True
.Replacement.Highlight = True
.Execute Replace:=wdReplaceAll
End With
[/vba]

6. go on to the next item in the arry ("very") and repeat 1 to 5.

Fine, Thanks friend for your detailed explanation.
Can you give me a macro to higlight any repeated words in the document. Say, "the the", "industry industry" or any words.
and another is
"David, 1999; David, 1899". can the macro find and higlight the repeated name "David". It may be any word. but the occurence of the word is that i have given above.

Hi Maheshdx,

What have you coded so far?

Coding for repeated words like "the the", or "industry industry", is not so difficult, but coding to recognise 'David' in a string like "David, 1999; David, 1899" is more problematic and would need a clear statement of what does and does not count as a repeat in such cases.

Plus, since this is a quite different issue to what the original thread was about, I think you really should starty a new thread for this problem.

Hi
Thanks for your replies from 1000 km far way. Sorry, i don't know how to start new thread. Can you do that. But is it possible to get the macro for "David, 1999; David, 1983". Help...

Hi Maheshdx,

I can't start the new thread - you have to do that.

And, when you do, please provide (a) what you have coded so far to solve your problem and (b) the rules for deciding when strings that aren't simple repeats of the same word (eg "David, 1999; David, 1899") should be highlighted. For example, I don't suppose you would want 'that' highlighted in a string like "Can you do that, if that is OK?".

Hi
I have started the new thread "Macro to higlight repeated words". I am poor in creating macros. But have ideas, thats why need your help. Please help.....

Is it possible to get it to highlight only if it exactly matches? Say for example you want to highlight AbC but not ABC?

Hi Gavin,

Before the '.Execute' line, insert a line with '.MatchCase = True'

Is there a way to have this saved in one doc and open it, then open a 2nd doc and run the code on it like you can in excel?

You can execute code in any document you like if the code is in a global template.

Hi

I think only a limited number of words can be added in the array. IF there are some 500 to 1000 words what can we do? arrWords = Array("I think that", "very"...)

You certainly can have over 500 words (elements) in an array. For an example with 1500 words, see the file attached to my post at:
http://lounge.windowssecrets.com/ind...owtopic=763675
The array in this case, is simply a very long text string.

If I may take advantage of this thread....

How do I highlight all instances of "win" (light blue, say) and "sit" (light red) excluding/omitting "twin", "swing", "site" and "visitor"?

Hope I haven't hijacked the thread.

Thank you.

The '.MatchWholeWord = True' setting takes care of the whole words part and, if you combine that with '.Font.ColorIndex = wdPink, or whatever, the words found will only be of the specified color. To get this to work for different colours in conjunction with the word list, you might have a case statement inside the array, a separate array for each colour, or a two-dimension array, with the second dimension holding the colour values (eg wdPink= 5).

A little beyond my present level. A good guideline, however. I'll take it, it's a challenge. Thank you very much, macropod.

Hi HJ,
When I said 'case statement inside the array', that should have been 'case statement inside the loop'.

After having spent some time, it's clear that I'm not yet apt to resolve the problem. So, I devised a simple ("lame") workaround that still helps:
::Please don't laugh::

[VBA]Sub ScratchMacro()
Dim oRng As Word.Range
Dim arrWords
Dim i As Long
arrWords = Array("I think that", "very")
For i = 0 To UBound(arrWords)
Set oRng = ActiveDocument.Range
With oRng.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = arrWords(i)
.MatchWholeWord = True
.Replacement.Highlight = True
.Execute Replace:=wdReplaceAll
End With
Next

arrWords = Array("the", "list", "of", "words", "to", "exclude")
For i = 0 To UBound(arrWords)
Set oRng = ActiveDocument.Range
With oRng.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = arrWords(i)
.MatchWholeWord = False
.Replacement.Highlight = False
.Execute Replace:=wdReplaceAll
End With
Next

End Sub [/VBA]Only thing's that the highlight color stays uniform throughout.

Hi HJ,

The fundamental issue is that you haven't told Word what to do with the found text. Aside from that, you code invests a lot of effort redifining things that only need to be defined once. Try it this way:

Code:

---

Sub Demo()
Dim oRng As Range, arrWords, i As Long
'Lines with an asterisk need to be defined only once
Set oRng = ActiveDocument.Range '*
With oRng.Find '*
  arrWords = Array("I think that", "very")
  .ClearFormatting '*
  .Replacement.ClearFormatting '*
  .MatchWholeWord = True '*
  .Replacement.Text = "^&" '*
  .Replacement.Highlight = True
  For i = 0 To UBound(arrWords)
    .Text = arrWords(i)
    .Execute Replace:=wdReplaceAll
  Next
  arrWords = Array("the", "list", "of", "words", "to", "exclude")
  .Replacement.Highlight = False
  For i = 0 To UBound(arrWords)
    .Text = arrWords(i)
    .Execute Replace:=wdReplaceAll
  Next
End With
End Sub

---

Hi macropod, your kindness while killing me is also very invigorating.
I changed the [VBA] .MatchWholeWord = True[/VBA]to[VBA] .MatchWholeWord = False[/VBA]and get the desired result. Now I oughta see if I can make the two arrayed words "I think that" & "very" highlighted in different colours.
Thanks once again.

Hi HJ,

AFAIK, you can't change the highlight colour within a straightforward Find/Replace, since the highlight colour index isn't a replacement parameter. However, if you define a character style with the desired background shading, you can apply that as a replacement criterion. Even that has its drawbacks, though, as it'll mess with any other character styles applying to the found text.

If you want to persevere with changing the highlight colour, you'll need a Do While loop that sets that parameter for each found range. I could show you how to do that, but I thought I'd leave it for you as a challenge ...

"you'll need a Do While loop that sets that parameter for each found range. I could show you how to do that, but I thought I'd leave it for you as a challenge ..."

Ok then, I will stay out of it. A good challenge, but not that difficult.

Following the last Next I inserted:[VBA] arrWords = Array("very")
.Replacement.Highlight = True
.Replacement.Font.Color = wdColorLightBlue
For i = 0 To UBound(arrWords)
.Text = arrWords(i)
.Execute Replace:=wdReplaceAll
Next
[/VBA]The result's apparent: the font colour changed to light blue, NOT touching the highlight colour. Not quite, but very close to what I'm seeking. Still a very inefficient way, I'm sure; yet the best I can think of for now. Thanks again!

Hi HJ,

Try something along these lines:

Code:

---

Sub Demo()
Dim oRng As Range, arrWords, i As Long, HiLite As Variant
Set oRng = ActiveDocument.Range
With oRng.Find
  arrWords = Array("very", "high")
  .ClearFormatting
  .Replacement.ClearFormatting
  .MatchWholeWord = False
  .Replacement.Text = "^&"
  .Replacement.Highlight = True
  HiLite = Options.DefaultHighlightColorIndex
  Options.DefaultHighlightColorIndex = wdYellow
  For i = 0 To UBound(arrWords)
    .Text = arrWords(i)
    .Execute Replace:=wdReplaceAll
  Next
  Options.DefaultHighlightColorIndex = HiLite
  arrWords = Array("the", "list", "of", "words", "to", "exclude")
  .Replacement.Highlight = False
  For i = 0 To UBound(arrWords)
    .Text = arrWords(i)
    .Execute Replace:=wdReplaceAll
  Next
  arrWords = Array("I think that")
  .Replacement.Highlight = True
  HiLite = Options.DefaultHighlightColorIndex
  Options.DefaultHighlightColorIndex = wdBrightGreen
  For i = 0 To UBound(arrWords)
    .Text = arrWords(i)
    .Execute Replace:=wdReplaceAll
  Next
  Options.DefaultHighlightColorIndex = HiLite
End With
Set oRng = Nothing
End Sub

---

Note: Contrary to my previous advice, the above approach obviates the need to set up a loop for pocessing the green highlights by selection the found ranges. You'll also see how, in this iteration of the code, I've captured and restored the previous highlighting attaributes.

I was trying to figure out how to exclude words in a Do While loop. But, gosh! This addresses the problem very well I'd better concentrate on some other things now. You're just wonderful, macropod. Thank you so so much!

Quote:

---

Originally Posted by macropod

Hi HJ,

Try something along these lines:

Code:

---

Sub Demo()
Dim oRng As Range, arrWords, i As Long, HiLite As Variant
Set oRng = ActiveDocument.Range
With oRng.Find
  arrWords = Array("very", "high")
  .ClearFormatting
  .Replacement.ClearFormatting
  .MatchWholeWord = False
  .Replacement.Text = "^&"
  .Replacement.Highlight = True
  HiLite = Options.DefaultHighlightColorIndex
  Options.DefaultHighlightColorIndex = wdYellow
  For i = 0 To UBound(arrWords)
    .Text = arrWords(i)
    .Execute Replace:=wdReplaceAll
  Next
  Options.DefaultHighlightColorIndex = HiLite
  arrWords = Array("the", "list", "of", "words", "to", "exclude")
  .Replacement.Highlight = False
  For i = 0 To UBound(arrWords)
    .Text = arrWords(i)
    .Execute Replace:=wdReplaceAll
  Next
  arrWords = Array("I think that")
  .Replacement.Highlight = True
  HiLite = Options.DefaultHighlightColorIndex
  Options.DefaultHighlightColorIndex = wdBrightGreen
  For i = 0 To UBound(arrWords)
    .Text = arrWords(i)
    .Execute Replace:=wdReplaceAll
  Next
  Options.DefaultHighlightColorIndex = HiLite
End With
Set oRng = Nothing
End Sub

---

Note: Contrary to my previous advice, the above approach obviates the need to set up a loop for pocessing the green highlights by selection the found ranges. You'll also see how, in this iteration of the code, I've captured and restored the previous highlighting attaributes.

---

Good morning,

apologies for dragging up this useful thread :)

Can someone help me with a quick query?

With regards to the code above, is it - and if so can someone show me - possible to display a message if one of the words listed in the array is found? Ie if "turkey" was listed and found by the macro it would display the message "You Have Entered a Restricted Word"

Many thanks, very useful site. :thumb

Try:

[VBA]Sub DemoX()
Dim oRng As Range, arrWords, i As Long, HiLite As Variant
Set oRng = ActiveDocument.Range
With oRng.Find
arrWords = Array("turkey", "vulture")
.ClearFormatting
.Replacement.ClearFormatting
.MatchWholeWord = False
.Replacement.Text = "^&"
.Replacement.Highlight = True
HiLite = Options.DefaultHighlightColorIndex
Options.DefaultHighlightColorIndex = wdYellow
For i = 0 To UBound(arrWords)
.Text = arrWords(i)
While .Execute(Replace:=wdReplaceOne)
oRng.Collapse wdCollapseEnd
MsgBox "You have used a restricted word: " & arrWords(i)
Wend
Next
End With
Set oRng = Nothing
End Sub

[/VBA]

Doesn't seem to work; however I will put this in the context of me being a total vba noob.

Here's what I've got, note I've altered the macro to run automatically when the document is saved, in case that makes a difference.

[vba]Sub FileSave()
'
'Sub Demo()
Dim oRng As Range, arrWords, i As Long, HiLite As Variant
Set oRng = ActiveDocument.Range
With oRng.Find
arrWords = Array("turkey", "vulture",)
.ClearFormatting
.Replacement.ClearFormatting
.MatchWholeWord = False
.Replacement.Text = "^&"
.Replacement.Highlight = True
HiLite = Options.DefaultHighlightColorIndex
Options.DefaultHighlightColorIndex = wdYellow
For i = 0 To UBound(arrWords)
.Text = arrWords(i)
.Execute Replace:=wdReplaceAll
Next
Options.DefaultHighlightColorIndex = HiLite
arrWords = Array("the", "list", "of", "words", "to", "exclude")
.Replacement.Highlight = False
For i = 0 To UBound(arrWords)
.Text = arrWords(i)
While .Execute(Replace:=wdReplaceOne)
oRng.Collapse wdCollapseEnd
MsgBox "You have used a restricted word: " & arrWords(i)
Wend
Next
Options.DefaultHighlightColorIndex = HiLite
End With
Set oRng = Nothing
ActiveDocument.Save
End Sub

[/vba]

wait, it's just kicked into life? Thanks!

Only slight issue is it says "You have used a restricted word: of"

Quote:

---

Originally Posted by TheMongoose

wait, it's just kicked into life? Thanks!

Only slight issue is it says "You have used a restricted word: of"

---

What would you have it say? The word 'of' is one of the words in the lookup array.

Oh yes, oops. Told you I was a noob!

Thanks for the help.

edit; Greg I've just realised I've used your own site before as well, very helpful too. Thanks again

One more question; would it be possible to list multiple instances of the words used? It currently says "You have used a restricted word: last word used" , could it be altered to "You have used a restricted word: X, X, X," ?

Hi

Further apologies for bring up an old thread but its so useful, I only have one question/request.


Instead of having
arrWords = Array("the", "list", "of", "words", "to", "exclude")

Is it possible foe the Array to reference a csv file or a simple list in a text file or indeed a word document?

The reason being is I have a 30 page business review document which I must review each week and look for names of our retail units and then highlight these and send on to the field team with the sites highlighted. The issues with writing out a long Array string is the list of sites does change from time to time and a long list is much easier to maintain than editing the script.

Thanks in advance and A great forum by the way, used many times but my uestions are normally answered without needing more help so have never signed up.

See, for example: http://www.vbaexpress.com/forum/show...ulkFindReplace. In that thread, an Excel workbook is used to hold the F/R data.

Gmaxey,
I am having trouble tracing the code you provided. I added a few terms to the array and have been stepping through the macro. It seems that when the first term is found and all of the instances of it have been replaced, the range is not redefined to include the entire document when looking for the next term. If the next term is not between where the range was collapsed and the end of the document, none of the remaining terms are found. How do you redefine the range to include the entire document again? All of the attempts I made in doing so caused an infinite loop. Please see my comments in the code below.

[VBA]Sub DemoX()
Dim oRng As Range, arrWords, i As Long, HiLite As Variant
Set oRng = ActiveDocument.Range
With oRng.Find
arrWords = Array("turkey", "and", "vulture", "pay", "an")
.ClearFormatting
.Replacement.ClearFormatting
.MatchWholeWord = False
.Replacement.Text = "^&"
.Replacement.Highlight = True
HiLite = Options.DefaultHighlightColorIndex
Options.DefaultHighlightColorIndex = wdYellow
For i = 0 To UBound(arrWords)
.Text = arrWords(i)
'Resetting the range below causeses an infinite loop
'Set oRng = ActiveDocument.Range
While .Execute(Replace:=wdReplaceOne)
oRng.Collapse wdCollapseEnd
MsgBox "You have used a restricted word: " & arrWords(i)
Wend
'Resetting the range below causeses an infinite loop here too. Setting a
' breakpoint here shows this line is never executed, yet an infinite loop
' still results. How does this happen?
'Set oRng = ActiveDocument.Range
Next
End With

Set oRng = Nothing
End Sub
[/VBA]

Try:

[VBA]Sub DemoXYZ()
Dim oRng As Range, arrWords, i As Long, HiLite As Variant

arrWords = Array("vulture", "turkey")
For i = 0 To UBound(arrWords)
Set oRng = ActiveDocument.Range
With oRng.Find
.ClearFormatting
.Replacement.ClearFormatting
.MatchWholeWord = False
.Replacement.Text = "^&"
.Replacement.Highlight = True
HiLite = Options.DefaultHighlightColorIndex
Options.DefaultHighlightColorIndex = wdGreen
.Text = arrWords(i)
While .Execute(Replace:=wdReplaceOne)
oRng.Collapse wdCollapseEnd
MsgBox "You have used a restricted word: " & arrWords(i)
Wend
End With
Next
Set oRng = Nothing
End Sub[/VBA]

Thank you Greg, now it works perfect. Looks like I was resetting the range object to the entire document from within the .find block, so of course the macro would be in an infinite loop. Understood now.