Sub ReplaceExcelCellvalueInMswordFile()
 
    Dim wdApp As Word.Application
    Dim wdDoc As Word.Document
 
    Dim SrcWb As Workbook
    Dim SrcWs As Worksheet
    Dim arrCnt As Integer
    Dim LastCol As Long
    Dim LastRow As Long
    Dim NxtRow As Long
    Dim arrFiles As Variant
    Dim FName As String
 
    Dim FilesPath As Variant
    Dim r, RR, RRR, R4, c, RecordCount, RecordCount_2, NewRecord, P, BreakLoop, OneRecordFill As Integer
    Dim Sum_AMT, Count_GL, Count_MISGrouping As Double
    Dim MISgroupName As Variant
    Dim str, str2, str3, str4 As String
 
    Dim iCount As Long
    Dim strSearch1, strSearch2, strReplace As String
 
    Const YOUR_REQUIRED_COLOR_IDX As Integer = 6 'RED'
    Dim doc As Range
    Set doc = ActiveDocument.Range
 
 
 
    'File picker
    Dim dlg As Variant
    Dim dataPath As Variant
    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)
        'Me!browseDataPath.Value = dataPath
    End If
 
    Set SrcWb = Workbooks.Open(dataPath, False, True)
                Set SrcWs = SrcWb.Sheets("DATA")
                 With SrcWs
 
 
                'Count the word
 
 
 
            r = 2
            str = SrcWs.Cells(r, 1).Value
            While str <> ""
                    strSearch1 = SrcWs.Cells(r, 1).Value
                    strSearch2 = SrcWs.Cells(r, 2).Value & " (" & SrcWs.Cells(r, 2).Value & ")"
                    strReplace = SrcWs.Cells(r, 2).Value
                    iCount = 0
 
                Application.Options.DefaultHighlightColorIndex = wdRed
                With ThisDocument.Content.Find
                    .Text = strSearch1
                    .Replacement.Text = strReplace
                    .Replacement.Highlight = True
                    .Wrap = wdFindContinue
                    .Execute Replace:=wdReplaceAll
                End With
 
 
                Application.Options.DefaultHighlightColorIndex = wdRed
                With ThisDocument.Content.Find
                    .Text = strSearch2
                    .Replacement.Text = strReplace
                    .Replacement.Highlight = True
                    .Wrap = wdFindContinue
                    .Execute Replace:=wdReplaceAll
                End With
 
 
            iCount = 0
 
 
 
            'Count the word and color
                With ThisDocument.Content.Find
                    .Text = strReplace
                    .Highlight = True
                    .Wrap = wdFindStop
                    Do While .Execute
 
                            iCount = iCount + 1
 
                    Loop
                End With
 
 
                If iCount > 1 Then
                  Application.Options.DefaultHighlightColorIndex = wdYellow
                  With ThisDocument.Content.Find
                    .Text = strReplace
                    .Replacement.Text = strReplace
                    .Highlight = True
                    .Replacement.Highlight = True
                    .Wrap = wdFindContinue
                    .Execute Replace:=wdReplaceAll
                  End With
 
                End If
 
 
 
 
 
                r = r + 1
                str = SrcWs.Cells(r, 1).Value
            Wend
 
 
        SrcWb.Close False
        End With
 
        Set SrcWs = Nothing
        Set SrcWb = Nothing
 
  MsgBox "Done"
 
End Sub

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

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"