Words with apostrophes can be accommodated easily enough by adding the apostrophe characters to the OnlyGetLetters function.
I have added unique words to the collection, but PLAINTIFF and plaintiff are considered to be the same word, so the practical solution is to change the search to ignore case.
Text boxes are frankly a pain as they are essentially graphics and not in the text story ranges. The following will also handle text boxes.
There are lots of instances of the letter 'a' highlighted. I have eliminated them with the two entries
If OnlyLetters(sText) = True And Len(sText) > 1 Then
If you want the 'a' instances highlighted remove the following bit from those two lines.
And Len(sText) > 1
You can find my web site at https://www.gmayor.com/Word_pages.htm if you wish to demonstrate your appreciation for the work that went into this.
Sub GetWords()
'Graham Mayor - https://www.gmayor.com - Last updated - 17 Sep 2021
Const sPath As String = "C:\Path\" 'the folder where the two documents are stored.
Const sSource As String = "FileA.docx"
Const sTarget As String = "FileB.docx"
Dim oSource As Document, oTarget As Document
Dim oStory As Range, oRng As Range
Dim oShp As Shape
Dim oCol As Collection
Dim oWord As Object
Dim sText As String
Dim i As Long
Set oCol = New Collection
Set oSource = Documents.Open(sPath & sSource)
Set oTarget = Documents.Open(sPath & sTarget)
On Error Resume Next
For Each oStory In oSource.StoryRanges
Select Case oStory.StoryType
Case 1 To 11
Do
For Each oWord In oStory.Words
sText = Trim(oWord)
If OnlyLetters(sText) = True And Len(sText) > 1 Then
oCol.Add sText, sText
End If
DoEvents
Next oWord
DoEvents
Select Case oStory.StoryType
Case 6, 7, 8, 9, 10, 11
If oStory.ShapeRange.Count > 0 Then
For Each oShp In oStory.ShapeRange
If oShp.TextFrame.HasText Then
For Each oWord In oShp.TextFrame.TextRange.Words
sText = Trim(oWord)
If OnlyLetters(sText) = True And Len(sText) > 1 Then
oCol.Add sText, sText
End If
DoEvents
Next oWord
End If
DoEvents
Next oShp
End If
Case Else
'Do Nothing
End Select
'Get next linked story (if any)
Set oStory = oStory.NextStoryRange
Loop Until oStory Is Nothing
Case Else
End Select
DoEvents
Next oStory
Options.DefaultHighlightColorIndex = wdYellow
For i = 1 To oCol.Count
Debug.Print oCol(i)
For Each oStory In oTarget.StoryRanges
Select Case oStory.StoryType
Case 1 To 11
Do
With oStory.Find
.ClearFormatting
.Text = CStr(oCol(i))
.Replacement.ClearFormatting
.Replacement.Text = "^&"
.Replacement.Highlight = True
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = True
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute Replace:=wdReplaceAll
End With
DoEvents
Select Case oStory.StoryType
Case 6, 7, 8, 9, 10, 11
If oStory.ShapeRange.Count > 0 Then
For Each oShp In oStory.ShapeRange
If oShp.TextFrame.HasText Then
Set oRng = oShp.TextFrame.TextRange
With oRng.Find
.ClearFormatting
.Text = CStr(oCol(i))
.Replacement.ClearFormatting
.Replacement.Text = "^&"
.Replacement.Highlight = True
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = True
.MatchWholeWord = True
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute Replace:=wdReplaceAll
End With
End If
DoEvents
Next oShp
End If
Case Else
'Do Nothing
End Select
'Get next linked story (if any)
Set oStory = oStory.NextStoryRange
Loop Until oStory Is Nothing
Case Else
End Select
DoEvents
Next oStory
Next i
MsgBox "Check complete!"
lbl_Exit:
oSource.Close 0
Set oWord = Nothing
Set oSource = Nothing
Set oTarget = Nothing
Set oRng = Nothing
Set oCol = Nothing
Exit Sub
End Sub
Private Function OnlyLetters(sWord As String) As Boolean
Dim intPos As Integer
For intPos = 1 To Len(sWord)
Select Case Asc(Mid(sWord, intPos, 1))
Case 65 To 90, 97 To 122, 146, 180
OnlyLetters = True
Case Else
OnlyLetters = False
Exit For
End Select
Next
lbl_Exit:
Exit Function
End Function