Application.ScreenUpdating = False
Dim lRow As Long, lTbl As Long
Dim RngFnd As Range, RngRep As Range, RngSrch As Range
Dim StrFnd As String, StrRep As String, StrSrch As String
With SrcWb
  SrcWs.UsedRange.Copy
  .Close False
End With
DoEvents
Set SrcWs = Nothing: Set SrcWb = Nothing
With ThisDocument
  .Range.InsertAfter vbCr
  .Characters.Last.Paste
  DoEvents
  lTbl = .Tables.Count
  Set RngSrch = .Range(0, .Tables(lTbl).Range.Start)
  For lRow = 2 To .Tables(lTbl).Rows.Count
    Set RngFnd = .Tables(lTbl).Rows(lRow).Cells(1).Range
    RngFnd.End = RngFnd.End - 1
    StrFnd = Trim(RngFnd.Text)
    Set RngRep = .Tables(lTbl).Rows(lRow).Cells(2).Range
    RngRep.End = RngRep.End - 1
    RngRep.Copy
    StrRep = Trim(RngRep.Text)
    Application.Options.DefaultHighlightColorIndex = wdRed
    With RngSrch.Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Format = False
      .MatchCase = False
      .MatchWholeWord = True
      .Wrap = wdFindContinue
      .Text = StrFnd & "^w(" & StrRep & ")"
      .Replacement.Text = StrFnd
      .Execute Replace:=wdReplaceAll
      .Text = StrFnd
      .Replacement.Text = "^c"
      .Replacement.Highlight = True
      .Execute Replace:=wdReplaceAll
    End With
    StrSrch = RngSrch.Text
    If (Len(StrSrch) - Len(Replace(StrSrch, StrRep, ""))) / Len(StrRep) = 1 Then
      Application.Options.DefaultHighlightColorIndex = wdYellow
      With RngSrch.Find
        .Text = StrRep
        .Replacement.Text = "^&"
        .Highlight = True
        .Replacement.Highlight = True
        .Wrap = wdFindContinue
        .Execute Replace:=wdReplaceOne
      End With
    End If
  Next
  .Tables(lTbl).Delete
  .Characters.Last.Delete
End With
Set RngSrch = Nothing: Set RngFnd = Nothing: Set RngRep = Nothing
Application.ScreenUpdating = True
MsgBox "Done"