Sub Demo()
Application.ScreenUpdating = False
Dim strFnd As String, wdDoc As Document, i As Long, j As Long, k As Long
Set wdDoc = Documents.Open(File:="Drive:\FilePath\SearchList.doc", Visible:=False, AddToRecentFiles:=False)
strFnd = Replace(wdDoc.Range.Text, vbLf, vbCr)
wdDoc.Close False
Set wdDoc = Nothing
While InStr(strFnd, vbCr & vbCr) > 0
  strFnd = Replace(strFnd, vbCr & vbCr, vbCr)
Wend
strFnd = Left(strFnd, Len(strFnd) - 1)
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
      For k = 0 To UBound(Split(strFnd, vbCr))
        If InStr(.Text, Split(strFnd, vbCr)(k)) > 0 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)
            If i = 1 Then .InsertAfter "Search Expression: " & strFnd & vbCr
            .InsertAfter "Instance: " & i & vbTab & "First matched on: " & Split(strFnd, vbCr)(k) & vbCr
            .Characters.Last.Paste
            While .Characters.Last.Previous.Previous = vbCr
              .Characters.Last.Previous.Previous.Delete
            Wend
          End With
          Exit For
        End If
      Next
      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