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