If the abbreviation in your document does not exist in the table, how is the macro supposed to know that it is an abbreviation?
You could perhaps search for all the items in your table and highlight the ones that do exist in the document, which might make those not present easier to spot manually (see below), but given that even in your table sample there are 13 different formats that reflect abbreviation types, producing a macro to identify all of these and the other 200+ formats that may exist is hardly practical.
Code:
Option Explicit
Sub FindAbbr()
Const sAbbrDoc As String = "C:\Path\Abbreviations.docx" 'the path of the abbreviations table document
Dim oDoc As Document, oAbbr As Document
Dim oTable As Table
Dim oRng As Range
Dim i As Long
If MsgBox("This could take some time!", vbOKCancel + vbInformation) = vbCancel Then
MsgBox "User cancelled", vbInformation
GoTo lbl_Exit
End If
Set oDoc = ActiveDocument
Set oAbbr = Documents.Open(sAbbrDoc)
Set oTable = oAbbr.Tables(1)
For i = 1 To oTable.Rows.Count
Set oRng = oTable.Cell(i, 1).Range
oRng.End = oRng.End - 1
Find_Replace oDoc, oRng.Text, "^&", False, True, True
DoEvents
Next i
oAbbr.Close 0
MsgBox "Search complete", vbInformation
lbl_Exit:
Set oDoc = Nothing
Set oAbbr = Nothing
Set oTable = Nothing
Set oRng = Nothing
Exit Sub
End Sub
Private Sub Find_Replace(ByRef oDoc As Word.Document, _
ByRef strFind As String, _
ByRef strReplace As String, _
Optional ByRef bMatchWC As Boolean, _
Optional ByRef bMatchCase As Boolean, _
Optional ByRef bFWWO As Boolean)
Dim rngStory As Word.Range
Dim oShp As Shape
For Each rngStory In oDoc.StoryRanges
Select Case rngStory.StoryType
Case 1 To 11
Do
SrcAndRplInStory rngStory, strFind, strReplace, _
bMatchWC, bMatchCase, bFWWO
On Error Resume Next
DoEvents
On Error GoTo 0
Select Case rngStory.StoryType
Case 6, 7, 8, 9, 10, 11
If rngStory.ShapeRange.Count > 0 Then
For Each oShp In rngStory.ShapeRange
If oShp.TextFrame.HasText Then
SrcAndRplInStory oShp.TextFrame.TextRange, _
strFind, strReplace, _
bMatchWC, bMatchCase, bFWWO
End If
DoEvents
Next oShp
End If
Case Else
'Do Nothing
End Select
On Error GoTo 0
'Get next linked story (if any)
Set rngStory = rngStory.NextStoryRange
Loop Until rngStory Is Nothing
Case Else
End Select
DoEvents
Next rngStory
lbl_Exit:
Set rngStory = Nothing
Exit Sub
err_Handler:
Resume lbl_Exit
End Sub
Private Sub SrcAndRplInStory(ByVal rngStory As Word.Range, _
ByVal strSearch As String, _
ByVal strReplace As String, _
ByVal bMatchWildCards As Boolean, _
ByVal bMatchCase As Boolean, _
ByVal bFindWWO As Boolean)
With rngStory.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = strSearch
.Replacement.Text = strReplace
.Replacement.Highlight = True
.MatchWildcards = bMatchWildCards
.MatchCase = bMatchCase
.MatchWholeWord = bFindWWO
.Execute Replace:=wdReplaceAll
End With
lbl_Exit:
Exit Sub
End Sub