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