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:


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

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



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

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