How to extract particular sentences containing more than one keywords?

[indc0001]

Hi ALL

I am a new VBA user and have some problems for extract particular sentences containing more than one keywords?

There is one Word Document I want to extract all sentences contain certain keywords

For example, the original file is

1. Introduction
1.1. Introduction
A should do someting
B must do something
C cannot do something
1.2 Heading 2
D shall do something
E has no plan

I want to extract sentences with 'shall', ' should' and 'must', so the extraction sentences with proper headings should be

1. Introduction
1.1. Introduction
A should do someting
B must do something
1.2 Heading 2
D shall do something

I got a code from Lucas in forum who can extract sentences by using only one Keyword (shall), I test it and it works! Just wonder is there anyone can help me to improve the code so it can extract sentences contain any Keywords (in my previ example, the keyword are shall', ' should' and 'must', sentences will be extracted if contain any of them), and all correspoing Headings should be extracted as well as show in above.

Option Explicit Sub FindWordCopySentence() Dim appExcel As Object Dim objSheet As Object Dim aRange As Range Dim intRowCount As Integer intRowCount = 1 Set aRange = ActiveDocument.Range With aRange.Find Do .Text = "shall" ' the word I am looking for .Execute If .Found Then aRange.Expand Unit:=wdSentence aRange.Copy aRange.Collapse wdCollapseEnd If objSheet Is Nothing Then Set appExcel = CreateObject("Excel.Application") 'Change the file path to match the location of your test.xls Set objSheet = appExcel.workbooks.Open("C:\temp\test.xls").Sheets("Sheet1") intRowCount = 1 End If objSheet.Cells(intRowCount, 1).Select objSheet.Paste intRowCount = intRowCount + 1 End If Loop While .Found End With If Not objSheet Is Nothing Then appExcel.workbooks(1).Close True appExcel.Quit Set objSheet = Nothing Set appExcel = Nothing End If Set aRange = Nothing End Sub

[gmaxey]

Lucas' code has nothing to do with copying previous paragraphs to Excel if they happen to be a heading. When you post code in the forums, post it between code tags so it can be read and copied properly:

Something like this may work.


Sub FindWordCopySentence()
Dim appExcel As Object
Dim objSheet As Object
Dim oRng As Range, oRngHeading As Range
Dim lngIndex As Long
Dim arrFind() As String
Dim bHdg1Flag As Boolean, bHdg2Flag As Boolean
Dim oPar As Paragraph
arrFind = Split("should,shall,must", ",")
For lngIndex = 0 To UBound(arrFind)
Set oRng = ActiveDocument.Range
With oRng.Find
.Text = arrFind(lngIndex)
While .Execute
bHdg1Flag = False: bHdg2Flag = False
Set oRngHeading = oRng.Paragraphs(1).Previous.Range
Do
If oRngHeading.Style = "Heading 1" Then
bHdg1Flag = True
oRngHeading.HighlightColorIndex = wdBrightGreen
End If
If oRngHeading.Style = "Heading 2" Then
bHdg2Flag = True
oRngHeading.HighlightColorIndex = wdBrightGreen
End If
If bHdg1Flag And bHdg2Flag Then Exit Do
Set oRngHeading = oRngHeading.Paragraphs(1).Previous.Range
Loop
oRng.Paragraphs(1).Range.HighlightColorIndex = wdBrightGreen
oRng.Collapse wdCollapseEnd
Wend
End With
Next
lngIndex = 1
Set appExcel = CreateObject("Excel.Application")
'Change the file path to match the location of your test.xls
Set objSheet = appExcel.workbooks.Open("D:\Test.xlsx").Sheets("Sheet1")
lngIndex = 1
For Each oPar In ActiveDocument.Paragraphs
If oPar.Range.HighlightColorIndex = wdBrightGreen Then
oPar.Range.HighlightColorIndex = wdAuto
objSheet.Cells(lngIndex, 1) = oPar.Range.Text
lngIndex = lngIndex + 1
End If
Next oPar
appExcel.workbooks(1).Close True
appExcel.Quit
Set objSheet = Nothing
Set appExcel = Nothing
lbl_Exit:
Exit Sub
End Sub