Sub ReplaceExcelCellValueInMswordFile()
Dim wdApp As Word.Application, wdDoc As Word.Document
Dim dlg As Variant, dataPath As Variant
Dim iCount As Long, r As Long
Dim strSearch, strReplace As String
r = 3
On Error Resume Next
Set wdApp = GetObject(, "Word.Application")
If Err.Number <> 0 Then 'Word isn't already running
  Set wdApp = CreateObject("Word.Application")
End If
On Error GoTo 0
Set dlg = Application.FileDialog(msoFileDialogFilePicker)
dlg.Title = "Select your MS word File for replace the word"
dlg.AllowMultiSelect = False
If dlg.Show = -1 Then
  dataPath = dlg.SelectedItems(1)
End If
Set wdDoc = wdApp.Documents.Open(dataPath, AddToRecentFiles:=False)
   wdApp.Visible = True
strSearch = Cells(r, 1).Value
While strSearch <> ""
  strReplace = Cells(r, 2).Value
  iCount = 0
  wdApp.Options.DefaultHighlightColorIndex = wdYellow
  With wdDoc.Content.Find
    .Text = strSearch
    .Replacement.Text = strReplace
    .Replacement.Highlight = True
    .Wrap = wdFindContinue
    .Execute Replace:=wdReplaceAll
  End With
  strSearch = wdDoc.Range.Text
  iCount = (Len(strSearch) - Len(Replace(strSearch, strReplace, ""))) / Len(strReplace)
  If iCount > 1 Then
    wdApp.Options.DefaultHighlightColorIndex = wdRed
     With wdDoc.Content.Find
      .Text = strReplace
      .Replacement.Text = strReplace
      .Replacement.Highlight = True
      .Wrap = wdFindStop
      .Execute Replace:=wdReplaceOne
     End With
  End If
  r = r + 1
  strSearch = Cells(r, 1).Value
Wend
MsgBox "Done"
End Sub