Sub Demo()
Application.ScreenUpdating = False
Dim wdDoc As Document, i As Long, j As Long, k As Long
Dim StrPri As String, StrSec As String, StrTmp As String, StrTxt As String, StrOut As String
StrSec = InputBox("What is the Secondary Text Array to Find?" _
  & vbCr & "Use the '|' character to separate array elements.")
If Trim(StrSec) = "" Then Exit Sub
Set wdDoc = Documents.Open(File:="Drive:\FilePath\SearchList.doc", Visible:=False, AddToRecentFiles:=False)
StrPri = Replace(wdDoc.Range.Text, vbLf, vbCr)
wdDoc.Close False
Set wdDoc = Nothing
While InStr(StrPri, vbCr & vbCr) > 0
  strFnd = Replace(StrPri, vbCr & vbCr, vbCr)
Wend
StrPri = Left(StrPri, Len(StrPri) - 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
      'Within each found block, check for a primary extraction string
      For i = 0 To UBound(Split(StrPri, vbCr))
        'If found, look for all the secondary strings
        If InStr(.Text, Split(StrPri, vbCr)(i)) > 0 Then
          For j = 0 To UBound(Split(StrSec, "|"))
            If InStr(.Text, Split(StrSec, "|")(j)) > 0 Then
              'Extract the text on the secondary string's line
              StrTmp = Split(.Text, Split(StrSec, "|")(j))(1)
              StrTmp = Split(StrTmp, vbCr)(0)
              StrOut = StrOut & vbCr & StrTmp
            End If
          Next
          Exit For
        End If
      Next
      If .End = x Then Exit Do
    End With
    .Collapse wdCollapseEnd
    .Find.Execute
  Loop
  'Clean up the output string, removing unwanted spaces and capitalising words
  StrTmp = StrOut
  StrOut = ""
  For i = 0 To UBound(Split(StrTmp, "/"))
    For j = 0 To UBound(Split(Trim(Split(StrTmp, "/")(i)), ","))
      StrTxt = Trim(Split(Trim(Split(StrTmp, "/")(i)), ",")(j))
      StrOut = StrOut & UCase(Left(StrTxt, 1)) & Right(StrTxt, Len(StrTxt) - 1) & ","
    Next
    StrOut = Left(StrOut, Len(StrOut) - 1) & "/"
  Next
End With
If StrOut = "" Then Exit Sub
Call ExcelOutput(StrOut)
Application.ScreenUpdating = True
End Sub
 
Sub ExcelOutput(StrIn As String)
Dim xlApp As Object, xlWkBk As Object, xlWkSht As Object
Dim StrTmp As String, i As Long, j As Long
'Start a new Excel session
Set xlApp = CreateObject("Excel.Application")
If xlApp Is Nothing Then
  MsgBox "Can't start Excel.", vbExclamation
  Exit Sub
End If
Set xlWkBk = xlApp.Workbooks.Add
' Ppopulate the workbook, with one row per line and
' separate columns for each /-delineated 'field'
With xlWkBk.Worksheets(1)
  For i = 0 To UBound(Split(StrIn, vbCr))
    StrTmp = Split(StrIn, vbCr)(i)
    For j = 0 To UBound(Split(StrTmp, "/")) - 1
      If Split(StrTmp, "/")(j) <> "" Then
        .Cells(i, j).Value = Split(StrTmp, "/")(j)
      End If
    Next
  Next
End With
'Show the Excel workbook
xlApp.Visible = True
' Release Excel object memory
Set xlWkBk = Nothing: Set xlApp = Nothing
End Sub