Highlight Phrases (not just individual words) from a Reference Document

[laura99]

Hello all,

I'm new to VBA and could use some help correcting some code I've written. I have a word doc ("checklist") with a table of 1000+ words and phrases. My macro is using this checklist to search other Word docs for these words and highlight them in blue font. However, the macro is searching each individual word rather than phrases as a whole (e.g. "Double" "Blind" and "Study" are highlighted instead of only "Double Blind Study"). Can someone help me with how to edit this code to only highlight the words in phrases if they are all found together? I can move the Checklist reference document to Excel instead of Word if that makes the coding simpler.

My code is below.

Thanks in advance!



Sub patientwordlistcheck()
'
' patientwordlistcheck Macro
'
'
Dim sCheckDoc As String
Dim docRef As Document
Dim docCurrent As Document
Dim wrdRef As Object


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


With Selection.Find
.ClearFormatting
.Replacement.ClearFormatting
.Replacement.Font.Color = wdColorBlue
.Replacement.Text = "^&"
.Forward = True
.Format = True
.MatchWholeWord = True
.MatchCase = False
.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

[gmayor]

I wouldn't personally do it like that, but if you have each word or phrase that you want to search for in a paragraph by itself in the document 'docRef' then the following will do the job:


Sub patientwordlistcheck()

Dim sCheckDoc As String
Dim docRef As Document
Dim docCurrent As Document
Dim oRng As Range
Dim oPara As Paragraph


sCheckDoc = "c:\checklist.docx" 'security may not allow you to save to the root of the C drive
Set docCurrent = Selection.Document
Set docRef = Documents.Open(sCheckDoc)
docCurrent.Activate


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


For Each oPara In docRef.Paragraphs
Set oRng = oPara.Range
oRng.End = oRng.End - 1
With Selection.Find
.Wrap = wdFindContinue
.Text = Trim(oRng.Text)
.Execute Replace:=wdReplaceAll
End With
Next oPara

docRef.Close
docCurrent.Activate
End Sub

[gmaxey]

Yes, that should word. If your existing checklist table contains one word or phrase per cell you could use it as follows:


Sub patientwordlistcheck()
Dim docRef As Document
Dim docCurrent As Document
Dim arrWords() As String
Dim lngIndex As Long
Set docCurrent = Selection.Document
Set docRef = Documents.Open("c:\checklist.docx")
docCurrent.Activate
With Selection.Find
.ClearFormatting
.Replacement.ClearFormatting
.Replacement.Font.Color = wdColorBlue
.Replacement.Text = "^&"
.Forward = True
.Format = True
.MatchWholeWord = True
.MatchCase = False
.MatchWildcards = False
End With
arrWords = Split(docRef.Tables(1).Range.Text, Chr(13) & Chr(7))
For lngIndex = 0 To UBound(arrWords)
If arrWords(lngIndex) <> vbNullString Then
With Selection.Find
.Wrap = wdFindContinue
.Text = Trim(arrWords(lngIndex))
.Execute Replace:=wdReplaceAll
End With
End If
Next
docRef.Close
docCurrent.Activate
End Sub

[laura99]

Thanks so much for your help with this. This almost works perfectly - it corrects the phrases question I asked about previously. However, it will highlight words in my document if the word in my checklist is only a part of the word in the document. For example, "inform" is on my list and I want it to be highlighted in my document when it appears; however it is highlighting "inform" even when it's part of the word "information" (which I don't want highlighted). It seems my "Match whole word" code only means for the checklist, not also the document. Can you help me with this as well?

Thanks again!



I wouldn't personally do it like that, but if you have each word or phrase that you want to search for in a paragraph by itself in the document 'docRef' then the following will do the job:


Sub patientwordlistcheck()

Dim sCheckDoc As String
Dim docRef As Document
Dim docCurrent As Document
Dim oRng As Range
Dim oPara As Paragraph


sCheckDoc = "c:\checklist.docx" 'security may not allow you to save to the root of the C drive
Set docCurrent = Selection.Document
Set docRef = Documents.Open(sCheckDoc)
docCurrent.Activate


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


For Each oPara In docRef.Paragraphs
Set oRng = oPara.Range
oRng.End = oRng.End - 1
With Selection.Find
.Wrap = wdFindContinue
.Text = Trim(oRng.Text)
.Execute Replace:=wdReplaceAll
End With
Next oPara

docRef.Close
docCurrent.Activate
End Sub

[gmayor]

Rearrange the code as follows:


Sub patientwordlistcheck()

Dim sCheckDoc As String
Dim docRef As Document
Dim docCurrent As Document
Dim oRng As Range
Dim oPara As Paragraph


sCheckDoc = "c:\checklist.docx" 'security may not allow you to save to the root of the C drive
Set docCurrent = ActiveDocument
Set docRef = Documents.Open(sCheckDoc)
docCurrent.Activate

For Each oPara In docRef.Paragraphs
Set oRng = oPara.Range
oRng.End = oRng.End - 1
With Selection.Find
.ClearFormatting
.Replacement.ClearFormatting
.Replacement.Font.Color = wdColorBlue
.Replacement.Text = "^&"
.Forward = True
.Format = True
.MatchWholeWord = True
.MatchCase = False
.MatchWildcards = False
.Wrap = wdFindContinue
.Text = Trim(oRng.Text)
.Execute Replace:=wdReplaceAll
End With
Next oPara

docRef.Close
docCurrent.Activate
End Sub