search document for words/phrases from a list

[PhilD]

Hello,
I have a list of about 200 phrases and words (common technical writing
errors not found in default Word grammer/style checker). How can quickly
find and highlight the occurences of the words/phrases in a document without
tediously using the find/replace function 200 times? I prefer a macro-free
method if availabe, since I know little about macros.

Another possible route: is there any way to customize the style checker
feature of the grammar checker, i.e., add phrases that Word search for which
it offers suggestions. There's gotta be some file that has a list the Word
uses.

I found a script for a macro on the internet, but, for example, for the
phrase "on behalf of" it would highlight every single occurrence of "on" and
"of" instead of requiring the phrase:
http://word.tips.net/Pages/T000502_Highlight_Words_from_a_Word_List.html

Thanks!
Phil

 

[Graham Mayor]

There is no simple or macro free way to do this. Even a method using macros
may be problematic to set up as you have already found. However the
following macro may help.
Put all your words and phrases in a document, each to a separate line, with
no empty paragraphs anywhere - especially at the end. Save it as a word
document then include the document name and its path in the line sFname =.
The macro ignores the case of the found words/phrases. If you want it to
match the case, change the .MatchCase = False line to .MatchCase = True.
http://www.gmayor.com/installing_macro.htm

Dim ChangeDoc As Document, RefDoc As Document
Dim oRng As Range
Dim oPara As Range
Dim i As Long
Dim sFname As String

sFname = "D:\My Documents\Test\Changes2.doc"

Set RefDoc = ActiveDocument
Set ChangeDoc = Documents.Open(sFname)
RefDoc.Activate
For i = 1 To ChangeDoc.Paragraphs.Count
Set oRng = ChangeDoc.Paragraphs(i).Range
oRng.End = oRng.End - 1
With Selection
.HomeKey wdStory
With .Find
.Text = oRng
.MatchWholeWord = True
.MatchCase = False
Do While .Execute(Forward:=True) = True
Selection.Range.HighlightColorIndex _
= wdYellow
Loop
End With
End With
Next i
ChangeDoc.Close wdDoNotSaveChanges


--
<>>< ><<> ><<> <>>< ><<> <>>< <>><<>
Graham Mayor - Word MVP


<>>< ><<> ><<> <>>< ><<> <>>< <>><<>

 

[PhilD]

Worked like a charm! I know this next question is a longshot: any way to
have word suggest changes (suggestions I would include in the word document)
as it does for spelling/grammer? I image this would involve editing the
(proprietary?) word grammar lists.

Thanks again,
Phil

 

[Graham Mayor]

Hmmm. It would be simple enough to replace the found text with another text,
but it starts to get a bit cumbersome if you want the user to pick from a
choice of replacements each time. That would be potentially 200 items each
of which may appear multiple times in a document?

Nevertheless the following could work. In this case the document containing
the words comprises a table with the words/phrases to find in the first
column and the choices of replacement in the second and subsequent columns.
You can have as many choices (each to a separate cell) as you can fit on the
page and you can have more or fewer (or no) choices for each word/phrase,
but don't leave any empty columns between the first column and any
subsequent filled columns on the same row. Fill from left to right.

If the word/phrase in the first column is found, the word/phrase is selected
and the user is given the list of possible replacements. If there are no
replacements listed the word is highlighted, otherwise the word is replaced
with the user's choice. The user input is error trapped against impossible
entry choices.

Although tested on a simple document with a limited number of selections, I
would suggest that you do not test it on a valuable document


Sub ReplaceFromTableList()
Dim ChangeDoc As Document, RefDoc As Document
Dim cTable As Table
Dim oldPart As Range, newPart, oFound As Range
Dim i, j, iCol As Long
Dim sFname, sReplaceText, sNum As String

sFname = "D:\My Documents\Test\changes.doc"
Set RefDoc = ActiveDocument
Set ChangeDoc = Documents.Open(sFname)
Set cTable = ChangeDoc.Tables(1)
RefDoc.Activate
For i = 1 To cTable.Rows.Count
Set oldPart = cTable.Cell(i, 1).Range
oldPart.End = oldPart.End - 1
With Selection
.HomeKey wdStory
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.MatchWholeWord = True
Do While .Execute(findText:=oldPart)
Set oFound = Selection.Range
iCol = 1
sReplaceText = ""
For j = 2 To cTable.Columns.Count
Set newPart = cTable.Cell(i, j).Range
newPart.End = newPart.End - 1
If Len(newPart) = 0 Then Exit For
sReplaceText = sReplaceText & iCol & ". " & _
newPart.Text & vbCr
iCol = iCol + 1
Next j
If Len(sReplaceText) <> 0 Then
Again:
sNum = InputBox(sReplaceText & vbCr & vbCr & _
"Enter the number of the replacement for '" _
& oldPart.Text & "'")
If sNum = "" Then Exit Sub
If IsNumeric(sNum) = False Then
MsgBox "Invalid entry! Try again.", _
vbInformation, "Error"
GoTo Again
End If
If sNum > cTable.Columns.Count Then
MsgBox "Invalid entry! Try again.", _
vbInformation, "Error"
GoTo Again
End If
If Len(cTable.Cell(i, sNum + 1).Range) = 2 Then
MsgBox "Invalid entry! Try again.", _
vbInformation, "Error"
GoTo Again
End If
Set newPart = cTable.Cell(i, sNum + 1).Range
newPart.End = newPart.End - 1
oFound.Text = newPart.Text
Else
oFound.HighlightColorIndex = wdYellow
End If
Loop
End With
End With
Next i
ChangeDoc.Close wdDoNotSaveChanges
End Sub


--
<>>< ><<> ><<> <>>< ><<> <>>< <>><<>
Graham Mayor - Word MVP


<>>< ><<> ><<> <>>< ><<> <>>< <>><<>