View words in extracted sentences

[montreal]

In reference to this thread: http://www.vbaexpress.com/forum/showthread.php?33093


Really useful post. Thanks so much. I am posting a little update to the code that permitted it to work for me.
Two things I would love.
1. That an option for a blank cell be added to the list built each time the loop switches to a new variable.
2. That a version of the code be posted that allows a list of regular expressions set up in the WordList.xls file to be used to search.

Here is the adapted code:


[vba]Sub SentencesToExcel()
Dim appExcel As Object
Dim objSheet As Object
Dim wbkXLNew As Object

Dim strSearch() As String
Dim var
Dim r As Word.Range
Dim j As Long

Set appExcel = CreateObject("Excel.Application")
Set wbkXLSource = appExcel.Workbooks.Open(FileName:="c:\temp\wordlist.xls")
Set wbkXLNew = appExcel.Workbooks.Add

For var = 0 To 300
' build the array of search words from the source Excel file
Redim Preserve strSearch(var)
strSearch(var) = wbkXLSource.Worksheets("Sheet1").Cells(var + 1, 1).Value
Next
' close the source Excel file as do not need it
wbkXLSource.Close
' destroy its object
Set wbkXLSource = Nothing
j = 1
' for each search words
For var = 0 To UBound(strSearch())
' make a range ovbject of the whole document
Set r = ActiveDocument.Range
With r.Find
' with each Found
Do While .Execute(Findtext:=strSearch(var), Forward:=True) _
= True
' expand to the sentence
r.Expand Unit:=wdSentence
' and put in the next cell in the new Excel file
wbkXLNew.Worksheets("Sheet1").Cells(j, 1).Value = r.Text
j = j + 1
r.Collapse 0
wbkXLNew.Worksheets("Sheet1").Cells(j, 1).Value = "break"
Loop
End With
Next
appExcel.Visible = True

'wbkXLNew.SaveAs FileName:="valid_path"
'Set wbkXLNew = Nothing
'appXL.Quit
'Set appXL = Nothing
End Sub[/vba]

[montreal]

So I have adapted the code above using earlier good work done in this thread to ensure that the word used for the search is in bold in the extracted sentence. I will post this new version below.

Would still love to:
1. Have a blank cell added at the start of a new variable for which there is something found.
2. To be able to have a list of regular expressions coming from a list in the file that could be used in the loop rather than a simple word or string.

Thanks again.



[vba]Sub SentencesToExcel()
Dim appExcel As Object
Dim objSheet As Object
Dim wbkXLNew As Object

Dim strSearch() As String
Dim var
Dim r As Word.Range
Dim j As Long

Set appExcel = CreateObject("Excel.Application")
Set wbkXLSource = appExcel.Workbooks.Open(FileName:="c:\temp\wordlist.xls")
Set wbkXLNew = appExcel.Workbooks.Add

For var = 0 To 300
' build the array of search words from the source Excel file
Redim Preserve strSearch(var)
strSearch(var) = wbkXLSource.Worksheets("Sheet1").Cells(var + 1, 1).Value
Next
' close the source Excel file as do not need it
wbkXLSource.Close
' destroy its object
Set wbkXLSource = Nothing
j = 1
' for each search words
For var = 0 To UBound(strSearch())
' make a range ovbject of the whole document
Set r = ActiveDocument.Range
With r.Find
' with each Found
Do While .Execute(Findtext:=strSearch(var), Forward:=True) _
= True
' expand to the sentence
r.Expand Unit:=wdSentence
' and put in the next cell in the new Excel file
wbkXLNew.Worksheets("Sheet1").Cells(j, 1).Value = r.Text
With wbkXLNew.Worksheets("Sheet1").Cells(j, 1)
ChrStart = InStr(wbkXLNew.Worksheets("Sheet1").Cells(j, 1), strSearch(var))
If ChrStart > 1 Then
With .Characters(Start:=ChrStart, Length:=Len(strSearch(var))).Font
.FontStyle = "Bold"
End With
End If
End With



j = j + 1
r.Collapse 0
wbkXLNew.Worksheets("Sheet1").Cells(j, 1).Value = "break"
Loop
End With
Next
appExcel.Visible = True

'wbkXLNew.SaveAs FileName:="valid_path"
'Set wbkXLNew = Nothing
'appXL.Quit
'Set appXL = Nothing
End Sub[/vba]

[macropod]

Would still love to:
1. Have a blank cell added at the start of a new variable for which there is something found.
2. To be able to have a list of regular expressions coming from a list in the file that could be used in the loop rather than a simple word or string.

For 1, you'd need to add logic to test whether the expression is found. For example, instead of:

With r.Find 
      ' with each Found
     Do While .Execute(Findtext:=strSearch(var), Forward:=True) _ 
         = True 
          ' expand to the sentence
         r.Expand Unit:=wdSentence 
          ' and put in the next cell in the new Excel file
         wbkXLNew.Worksheets("Sheet1").Cells(j, 1).Value = r.Text 
         With wbkXLNew.Worksheets("Sheet1").Cells(j, 1) 
             ChrStart = InStr(wbkXLNew.Worksheets("Sheet1").Cells(j, 1), strSearch(var)) 
             If ChrStart > 1 Then 
                 With .Characters(Start:=ChrStart, Length:=Len(strSearch(var))).Font 
                     .FontStyle = "Bold" 
                 End With 
                  
             End If 
         End With
         j = j + 1 
         r.Collapse 0 
         wbkXLNew.Worksheets("Sheet1").Cells(j, 1).Value = "break" 
     Loop 
 End With

you might use something like:

Dim xlWkSht As WorkWheet
Set xlWkSht = wbkXLNew.Worksheets("Sheet1")
With r
  With .Find
    .Text = strSearch(var)
    .Forward = True
    .Wrap = wdFindStop
    .Execute
  End With
  If .Find.Found = False Then j = j + 1
  ' with each Found
  Do While .Find.Found = True
    ' put the sentence in the next cell in the new Excel file
    xlWkSht.Cells(j, 1).Value = .Duplicate.Sentences.First
    With xlWkSht.Cells(j, 1)
      ChrStart = InStr(xlWkSht.Cells(j, 1), strSearch(var))
      If ChrStart > 1 Then .Characters(Start:=ChrStart, _
        Length:=Len(strSearch(var))).Font.FontStyle = "Bold"
    End With
    j = j + 1
    .Collapse 0
    .Find.Execute
    xlWkSht.Cells(j, 1).Value = "break"
  Loop
End With

For 2, you could either reference a different worksheet that contains the wildcard expressions, or pre-fine the cell range for normal expressions and have the wildcard expressions as a separate range, all on the same worksheet. In either case, you'd process the wildcard expressions via a separate loop with '.Wildcards = True'.

PS: When posting code, please use the code tags, indicated by the # symbol on the posting menu.