Sub Demo()
Application.ScreenUpdating = False
Dim strFnd As String, wdDoc As Document, i As Long, j As Long
strFnd = InputBox("What is the Text to Find")
If Trim(strFnd) = "" Then Exit Sub
With ActiveDocument.Range
  j = .End
  With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "^94[!^94]"
    .Replacement.Text = ""
    .Forward = True
    .Wrap = wdFindStop
    .Format = False
    .MatchWildcards = True
    .Execute
  End With
  Do While .Find.Found = True
    With .Duplicate
      .Start = .Start + 1
      .MoveEndUntil Cset:="^", Count:=wdForward
      If InStr(.Text, strFnd) Then
        If wdDoc Is Nothing Then Set wdDoc = Documents.Add
        i = i + 1
        While .Characters.First = vbCr
          .Start = .Start + 1
        Wend
        .Copy
        With wdDoc.Range
          .InsertAfter Chr(12) & "Instance: " & i & vbCr
          .Characters.Last.Paste
          While .Characters.Last.Previous.Previous = vbCr
            .Characters.Last.Previous.Previous.Delete
          Wend
        End With
      End If
      If .End = j Then Exit Do
    End With
    .Collapse wdCollapseEnd
    .Find.Execute
  Loop
End With
If Not wdDoc Is Nothing Then wdDoc.Characters.First.Delete
Set wdDoc = Nothing
Application.ScreenUpdating = True
MsgBox i & " instances found."
End Sub