With objWrdApp.Selection.Find
    .Text = "test" ' Ищет в Ворде текст,который нужно.
    Do
        res = .Execute
        If res Then
            'Заливка
            objWrdApp.Selection.Shading.BackgroundPatternColor = wdColorYellow
            'Выделение
            'objWrdApp.Selection.Range.HighlightColorIndex = wdRed
            cnt = cnt + 1
        End If
    Loop While res
End With
Debug.Print cnt

Option Explicit

Public Sub findStr()
Dim objWrdApp As Object
Dim str1 As String
Dim objWrdDoc As Object
Dim i As Long, r As Word.Range

On Error Resume Next
ThisWorkbook.VBProject.References.AddFromFile Application.Path & Application.PathSeparator & "MSWORD.OLB"
Set objWrdApp = GetObject(, "Word.Application")
If objWrdApp Is Nothing Then Set objWrdApp = CreateObject("Word.Application")
Set objWrdDoc = objWrdApp.Documents.Open(ThisWorkbook.Path & "\2.docx")

str1 = Cells(2, 1).Value
objWrdApp.Visible = True
objWrdApp.Activate
' number text
Set r = objWrdApp.Selection.Range
  With r.Duplicate.Find
    .ClearFormatting
    Do While .Execute(str1, False, False, Wrap:=wdFindStop)
      i = i + 1 'количество вхождений
    Loop
  End With
  ' end number text
' выделение цветом
objWrdApp.Selection.Find.ClearFormatting
objWrdApp.Selection.Find.Replacement.ClearFormatting
Options.DefaultHighlightColorIndex = wdRed ' цвет выделения
With objWrdApp.Selection.Find
    .Text = str1 ' Ищет в Ворде текст,который нужно.
    .Replacement.Text = str1    ' текст для замены
    .Replacement.Highlight = True
    .Forward = True
    .Wrap = wdFindContinue
    .Format = True
    .MatchCase = False
    .MatchWholeWord = False
    .MatchWildcards = False
    .MatchSoundsLike = False
    .MatchAllWordForms = False
End With
objWrdApp.Selection.Find.Execute Replace:=wdReplaceAll

Set objWrdDoc = Nothing
Set objWrdApp = Nothing
End Sub