Try:
Code:
Sub DataExtract()
Application.ScreenUpdating = False
Dim StrPri As String, StrSec As String, StrTmp As String, StrTxt As String, StrOut As String
Dim i As Long, j As Long, x As Long
StrPri = InputBox("What is the Primary Text Array to Find?" _
& vbCr & "Use the '|' character to separate array elements.")
If Trim(StrPri) = "" Then Exit Sub
StrSec = InputBox("What is the Secondary Text Array to Find?" _
& vbCr & "Use the '|' character to separate array elements.")
If Trim(StrSec) = "" Then Exit Sub
With ActiveDocument.Range
x = .End
'Find text blocks bounded by caret (^) symbols
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, "|"))
'If found, look for a secondary string
If InStr(.Text, Split(StrPri, "|")(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 the code doesn't have to do any of the work associated with an existing workbook, the Excel part can be much simpler than otherwise.