Dim iCount As Long, r As Long
Dim strSearch, strReplace As String
With SrcWs
  'Count the word
  r = 2
  strSearch = SrcWs.Cells(r, 1).Value
  While strSearch <> ""
    strReplace = SrcWs.Cells(r, 2).Value
    SrcWs.Cells(r, 2).Copy
    Application.Options.DefaultHighlightColorIndex = wdYellow
    With ThisDocument.Content
      With .Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Format = False
        .MatchCase = False
        .MatchWholeWord = True
        .Wrap = wdFindContinue
        .Text = strSearch & "^w(" & strReplace & ")"
        .Replacement.Text = strSearch
        .Execute Replace:=wdReplaceAll
        .Text = strSearch
        .Replacement.Text = "^c"
        .Replacement.Highlight = True
        .Execute Replace:=wdReplaceOne
      End With
      While .Find.Found
        .Duplicate.Tables(1).ConvertToText Separator:=wdSeparateByTabs
        .Duplicate.Characters.Last.Delete
        .Find.Execute Replace:=wdReplaceOne
      Wend
    End With
    strSearch = ThisDocument.Range.Text
    iCount = (Len(strSearch) - Len(Replace(strSearch, strReplace, ""))) / Len(strReplace)
    If iCount > 1 Then
      Application.Options.DefaultHighlightColorIndex = wdRed
      With ThisDocument.Content.Find
        .Text = strReplace
        .Replacement.Text = "^&"
        .Highlight = True
        .Replacement.Highlight = True
        .Wrap = wdFindContinue
        .Execute Replace:=wdReplaceOne
      End With
    End If
    r = r + 1
    strSearch = SrcWs.Cells(r, 1).Value
  Wend
  SrcWb.Close False
End With