Assuming the data errors you discovered in the other thread are the issue for this one also, try the following:
Code:
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
As with the other thread, simply create your input document with a separate line(paragraph) for each entry (no '|' characters for separators), then replace 'Drive:\FilePath\SearchList.doc' in the code with the input document's full path & name.
With the above code, you'll still be asked for the secondary string, which should be input like 'NAM|ID' (without the single quotes).