Macro that can find phrase and then find another and copy

jperez84 · #1 09-13-2012, 10:35 AM

Good afternoon,

The macro I'm trying to setup should first find a certain phrase (there will be many different ones and would like to put them all in at once), let’s say “hello there buddy”. From there it will search for another set of characters above it. Let’s say “NAM/” and it will copy that entire line (if there is a way to tell it only to copy between the first set on “//” or the second, etc is even better) . The only thing is that it’s never the same amount of characters above or lines above. From there it will copy the text into an excel spreadsheet. Also, is it possible for the macro to find "NAM/" and lets say "test" and copy both lines and put them next to each other in two separate cells? Or should a second macro be rum and just change the parameters? Below is an example of how the word doc is setup. Setup is similar to another question I posted a few days ago, but the output s different.

Thanks in advance.

^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
test1 NAM/smith, peter/ jackson, Samantha/
123
test
unneeded info

hello there buddy

^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
test2 NAM/jones,Jeffrey/ sandler,adam/
356
another
test
can you
believe it
I can’t
hello there buddy

macropod · #2 09-14-2012, 04:59 AM

For the most part, the Find process is much the same as in your other post. However, if you're both looking for multiple primary strings (eg 'hello there buddy|monday morning') and multiple secondary strings (eg NAM|ID) at the same time, that could make things complicated. As for populating Excel, that's quite doable but could end up accounting for 80% of the final code. Do you already have the Excel workbook the data are to go in, or is the macro to create a new one?

jperez84 · #3 09-14-2012, 06:10 AM

The macro is to create a new one. The cells where the data needs to go might change. Will it be easy for me to be able to change the cells in the macro?I don't know if its possible or if this would work period but could the macro find the first phrase "hello there buddy" then look above to find the first secondary string "NAM". Then copy paste and then return to the first phrase and look above again for this time the second secondary string "ID" copy, paste. Then it will move to the second phrase. Thanks for your help.

macropod · #4 09-14-2012, 08:07 PM

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.

jperez84 · #5 09-18-2012, 03:26 PM

Hey Macropod,

This macro also isn't working for me. it goes through the process but Excel never opens. You said that it's easier if I already have an Excel doc open. Can we modify the current macro? Also, I'm trying to learn the coding aspect and have some other ideas for the macro. I'm thinking of making it find additional lines of text. Is the code below correct?

Code:

StrSec = InputBox("What is the Third Text Array to Find?" _
  & vbCr & "Use the '|' character to separate array elements.")
If Trim(StrThrd) = "" Then Exit Sub

Code:

If InStr(.Text, Split(StrPri, "|")(k)) > 0 Then
          For j = 0 To UBound(Split(StrThrd, "|"))
            If InStr(.Text, Split(StrThrd, "|")(k)) > 0 Then
              'Extract the text on the third string's line
              StrTmp = Split(.Text, Split(StrThrd, "|")(k))(1)
              StrTmp = Split(StrTmp, vbCr)(0)
              StrOut = StrOut & vbCr & StrTmp
            End If
          Next
          Exit For
        End If

I don't know how to do the Excel portion though. Also, If instead of an input box we can have it read from a list I think that would work better.

Thanks for your help.

macropod · #6 09-18-2012, 03:50 PM

The code works fine in my testing. The Excel workbook will only be created if something has been found. As mentioned in the other thread, the searches are case-sensitive.

Quote:

You said that it's easier if I already have an Excel doc open.

I think you have misunderstood what I said. If the workbook is supposed to exist already, a lot more coding is required, including code to test whether the workbook is already opened.

jperez84 · #7 09-18-2012, 04:37 PM

That's whats weird. I first did a find in the doc to make sure that what is being searched for is actually in the doc and it is. Did my code look right?

macropod · #8 09-18-2012, 04:49 PM

You don't need your version of 'StrSec'. The code I posted will already find multiple secondary expressions for each primary string. It also looks to me like your revision would simply overwrite the StrSec that's already in use.

Have you actually tried the code as I posted it? As I said, it works fine in my testing - with multiple primary and secondary strings.

jperez84 · #9 09-18-2012, 04:59 PM

Yes, I tried it how you posted it. I'm going to retry it tomorrow and check to make sure its case sensitive. For this macro it would also help to be able to feed it a list for the first search string because they add up to more than 256 characters.

So, for the searches, if my primary search is DIN/A123456789|DIN/987654 and my secondary is NAM|ID|.QW ., the three secondaries will be searched for each primary. Thanks.

jperez84 · #10 09-19-2012, 08:59 AM

Ok, I tested it again and no luck. The macro runs and I get no errors, but Excel doesn't open.

macropod · #11 09-19-2012, 04:48 PM

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).

Thread Tools
Show Printable Version Email this Page
Display Modes
Linear Mode Switch to Hybrid Mode Switch to Threaded Mode

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Find, copy and paste into a new page	jperez84	Word VBA	24	09-20-2012 11:34 AM
Trying to find and copy all headings at the same time	WaltR	Word	7	08-21-2012 03:12 PM
How to find exact phrase	CabbageTree	Outlook	2	05-14-2012 11:24 AM
Bad view when using Find and Find & Replace - Word places found string on top line	paulkaye	Word	4	12-06-2011 11:05 PM
Find and Replace Macro - A Better Way	Tribos	Word VBA	0	10-08-2008 03:22 AM