Try something along these lines:
Code:
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