How to highlight text in a Word document using a word list from another document

Gilvv · #1 10-16-2016, 11:57 PM

Hello.

I have a MS Word document that I need to check against a table of terms contained in another MS Word document. Essentially, I need to highlight the phrases/words in the document that coincide with phrases/words contained in the table of terms. The table of terms is formatted like this:

duplicate line item
duplicate procedures
duplication of benefits
Durable Medical Equipment (DME)
durable medical equipment exceeds rental cost
durable medical equipment maximum frequency

As a first attempt, I tried the code below. The problem is that it highlights EVERY SINGLE WORD from the table of terms. As I explained, I only want to highlight the phrases/words that coincide exactly with the phrases/words from the table (although many of the entries are single words, as a matter of fact). I tried to modify the code but didn’t have any luck. Thanks in advance for whatever help/guidance you can give me.

Code:

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.Highlight = True
          .Replacement.Text = "^&"
          .Forward = True
          .Format = True
          .MatchCase = True
          .MatchWildcards = False
      End With
   
      For Each wrdRef In docRef.Words
          If Asc(Left(wrdRef, 1)) > 32 Then
              With Selection.Find
                  .MatchWholeWord = True
                  .Wrap = wdFindContinue
                  .Text = wrdRef
                  .Execute Replace:=wdReplaceAll
              End With
          End If
      Next wrdRef
   
      docRef.Close
      docCurrent.Activate
  End Sub

macropod · #2 10-17-2016, 01:05 AM

There have been numerous threads in this forum discussing the kind of thing you want, complete with solutions. Try a search.

Gilvv · #3 10-17-2016, 07:13 AM

Thank you, I'll try.

Gilvv · #4 10-25-2016, 10:01 PM

Hello, Macropod.

Thank you for your advice. Through some search and trial and error I was able to do what I aimed: Highlight words and, specially, full phrases I wanted to identify in my text. I have now another problem: Next to each term that has been identified and highlighted I need to add, in hidden text, a small (glossary like) explanation of that highlighted term.

I start with a table that in the first column contains the terms that are going to be identified and highlighted. The second column contains the glossary-like explanation of the terms contained in the first column. I’m struggling to produce a feasible code. Would you have any recommendation and/or advice on how to proceed? I greatly appreciate beforehand any help you can offer me. (These are really my first attempts into VBA programming and, after some considerable search, I haven't found any thread addressing this matter.)

macropod · #5 10-28-2016, 01:24 AM

You could use Word's 'comment' tool to add the explanatory text. For example:

Code:

Sub Demo()
Application.ScreenUpdating = False
Dim FRDoc As Document, strFnd As String, strRep As String, i As Long
Set FRDoc = Documents.Open("Drive:\FilePath\FindTableData.doc", _
  ReadOnly:=True, AddToRecentFiles:=False, Visible:=False)
For i = 1 To FRDoc.Tables(1).Rows.Count
  strFnd = Split(FRDoc.Tables(1).Cell(i, 1).Range.Text, vbCr)(0)
  strRep = Split(FRDoc.Tables(1).Cell(i, 2).Range.Text, vbCr)(0)
  With ActiveDocument.Range
    With .Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Format = False
      .MatchCase = True
      .MatchWholeWord = True
      .MatchWildcards = False
      .Wrap = wdFindStop
      .Text = strFnd
      .Execute
    End With
    Do While .Find.Found
      .HighlightColorIndex = wdBrightGreen
      .Comments.Add .Duplicate, strRep
      .Collapse wdCollapseEnd
      .Find.Execute
    Loop
  End With
Next
Application.ScreenUpdating = True
End Sub

Gilvv · #6 10-30-2016, 12:27 PM

Thank you very much, macropod!

You are truly a master!

I do appreciate your beautiful, elegant solution. Thank you for taking the time to address my question!

I applied your code to one of my texts and it works like a charm. However, there is a little problem I’m trying to resolve applying the same idea you suggested (using Comments for the explanatory text): My table of terms is rather large (about 4300 rows) and running the code takes a long time –more than 6 or 7 minutes for a small text (2 pages) that I’m using for testing. The code below, which I used to only highlight the matching terms, took 20 seconds or so for the same text. Would adding the comments add that much time?

Once again, macropod, thank you very much for your help!

PS. Seeing your code really gives me the motivation and inspiration to learn VBA in depth. (Any recommendation for a text or handbook I could use?)

Code:

Sub Finder()
      Dim sCheckDoc As String
      Dim docRef As Document
      Dim docCurrent As Document
      Dim wrdRef As String
      Dim wrdPara As Paragraph
   
      sCheckDoc = "c:\FilePath\Glossary.docx"
      Set docCurrent = Selection.Document
      Set docRef = Documents.Open(sCheckDoc)
      docCurrent.Activate
   
      With Selection.Find
          .ClearFormatting
          .Replacement.ClearFormatting
          .Replacement.Highlight = True
          .Replacement.Text = "^&"
          .Forward = True
          .Format = True
          .MatchWholeWord = False
          .MatchCase = False
          .MatchWildcards = False
      End With
   
      For Each wrdPara In docRef.Paragraphs
          wrdRef = wrdPara.Range.Text
          wrdRef = Left(wrdRef, Len(wrdRef) - 1)
              If Asc(Left(wrdRef, 1)) > 32 Then
                  With Selection.Find
                  .MatchWholeWord = True
                  .MatchCase = False
                  .MatchSoundsLike = False
                  .Wrap = wdFindContinue
                  .Text = wrdRef
                  .Execute Replace:=wdReplaceAll
      End With
              End If
      Next wrdPara
   
      docRef.Close
      docCurrent.Activate
  End Sub

macropod · #7 10-30-2016, 10:46 PM

Adding comments and retrieving the contents of a second column from the table will both slow down the code's execution. The main reason for the slower execution is that the Find/Replace can't be done as a single operation using wdReplaceAll when adding comments; instead each found instance must be individually processed.

A possible workaround would be to add the comments to the text in the table (i.e. using only one column), which you would also highlight, then let the macro copy each cell's content to the clipboard and use for the replacement, thus:

Code:

Sub Demo()
Application.ScreenUpdating = False
Dim FRDoc As Document, strFnd As String, RngFnd As Range, i As Long
Set FRDoc = Documents.Open("C:\FilePath\Glossary.docx", _
  ReadOnly:=True, AddToRecentFiles:=False, Visible:=False)
With ActiveDocument.Range.Find
  .ClearFormatting
  .Replacement.ClearFormatting
  .Format = True
  .Replacement.Text = "^c"
  .MatchCase = True
  .MatchWholeWord = True
  .MatchWildcards = False
  .Wrap = wdFindContinue
  For i = 1 To FRDoc.Tables(1).Rows.Count
    Set RngFnd = FRDoc.Tables(1).Cell(i, 1).Range
    With RngFnd
      .End = .End - 1
      .Copy
      strFnd = .Text
    End With
    .Text = strFnd
    .Execute Replace:=wdReplaceAll
  Next
End With
Application.ScreenUpdating = True
End Sub

The drawback with this approach is that the format of the replacement will be the same as whatever is in the table.

Gilvv · #8 11-01-2016, 03:05 PM

Thank you so much, macropod!
I'm so grateful for your help.

As always, your solution is elegant.

Just for future reference, I would like to mention a little problem I had with this part of the code:

Code:

Set RngFnd = FRDoc.Tables(1).Cell(i, 1).Range
      With RngFnd
        .End = .End - 1
        .Copy
        strFnd = .Text
      End With
      .Text = strFnd

When I run it, it didn't find any match when clearly there were many. Then I introduced a small modification:

Code:

Set RngFind = GlossaryDoc.Tables(1).Cell(i, 1).Range
    With RngFind
        .Copy
        .End = .End - 2
      strFind = .Text
    End With
    .Text = strFind

It works fine now but there is a little final problem: The replacement text keeps the column formatting (which I don't want). It is probably a stupid question but is there a simple command to copy into the clipboard that highlighted, commented text in regular format?

Once again, Paul (macropod), thank you so very much for all of your help.

macropod · #9 11-01-2016, 03:27 PM

Changing:
.End = .End - 1
to:
.End = .End - 2
indicates you have some extraneous content between the 'find' expression and the end-of-cell marker. A space or paragraph break, perhaps?

As for:

Quote:

there is a little final problem: The replacement text keeps the column formatting (which I don't want).

I did warn you:

Quote:

The drawback with this approach is that the format of the replacement will be the same as whatever is in the table.

Gilvv · #10 11-01-2016, 04:44 PM

Thanks again for explaining and clarifying.

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Find and highlight multiple words in MS Word document	AtaLoss	Word VBA	37	09-22-2021 12:04 PM
Linking one word document to a 'master' word document - even if files are in private drive	mb3344	Word	2	08-06-2016 07:10 PM
Adding tables to Created word document whilst other word document open Help	rpb925	Word VBA	18	03-30-2016 04:45 PM
Word document with Macros with trusted locatin versus Word document 1997-2003	Cardinal2	Word	1	11-30-2015 07:42 PM
Can Word highlight the same text in the Reviewing Pane as in the main document?	wordistheword	Word	4	09-09-2013 04:50 AM