Sub Demo()
Application.ScreenUpdating = False
Dim RngDoc As Range, oTbl As Table, strFnd As String, i As Long, j As Long
With ActiveDocument
  Set oTbl = .Tables(1)
  For i = 1 To oTbl.Rows.Count
    strFnd = Split(oTbl.Cell(i, 2).Range.Text, vbCr)(0)
    Set RngDoc = ActiveDocument.Range
    RngDoc.Start = oTbl.Range.End
    With RngDoc
      With .Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Format = False
        .Text = strFnd
        .MatchWholeWord = True
        .MatchWildcards = False
        .MatchCase = True
        .Execute
      End With
      j = 0
      Do While .Find.Found
        j = j + 1
        .Collapse wdCollapseEnd
        .Find.Execute
      Loop
    End With
    If j > 0 Then oTbl.Cell(i, 3).Range.Text = j
  Next
End With
Application.ScreenUpdating = True
End Sub