View Single Post
 
Old 09-14-2012, 08:07 PM
macropod's Avatar
macropod macropod is offline Windows 7 64bit Office 2010 32bit
Administrator
 
Join Date: Dec 2010
Location: Canberra, Australia
Posts: 21,956
macropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond repute
Default

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.
__________________
Cheers,
Paul Edstein
[Fmr MS MVP - Word]
Reply With Quote