Sub Demo()
Application.ScreenUpdating = False
Dim i As Long, StrFnd As String, CharExcl As String, StrTmp As String
CharExcl = ",.(?)/\¬(!)£$%^&(*)(-)+=’'”@(#)~:;|<>¦_{}([)()"

StrFnd = Trim(InputBox("What is the Text to Find"))
If StrFnd = "" Then Exit Sub
With ActiveDocument.Range
  With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = StrFnd
    .Replacement.Text = ""
    .Forward = True
    .Wrap = wdFindStop
    .Format = False
    .MatchCase = False
    .MatchWildcards = True
    .Execute
  End With
  Do While .Find.Found
    i = i + 1
    With .Duplicate
      StrTmp = .Text
      If Not .Characters.First.Previous.Text Like _
       "[ ‘'“" & Chr(160) & Chr(12) & vbCr & vbTab & "]" Then
        StrTmp = " " & StrTmp
      End If
      If Not .Characters.Last.Next.Text Like _
        "[ " & CharExcl & Chr(160) & Chr(12) & vbCr & vbTab & "]" Then
        If Not .Characters.Last.Next.Text = "]" Then
          StrTmp = StrTmp & " "
        End If
      End If
    End With
    If .Text <> StrTmp Then .Text = StrTmp
    .Collapse wdCollapseEnd
    .Find.Execute
  Loop
End With
Application.ScreenUpdating = True
MsgBox i & " instances found."
End Sub