Copy paragraph with certain keyword available under a searched word

[Jmac2604]

Hi,
I am new to word automation. I got the below code which will search for a keyword in word and will extract the second paragraph below it. But I want is instead takin the second paragraph blindly it needs extract the paragraph based on a specific word in the beginning. Please help me on this if possible.

My code is


Option Compare Text

Sub LocateSearchItem()
Application.EnableEvents = False
Dim shtSearchItem As Worksheet
Dim shtExtract As Worksheet
Dim oWord As Word.Application
Dim WordNotOpen As Boolean
Dim oDoc As Word.Document
Dim oRange As Word.Range
Dim LastRow As Long
Dim CurrRowShtSearchItem As Long
Dim CurrRowShtExtract As Long
Dim myPara As Long
Dim rCell As Range
Dim str
Dim objPic As InlineShape
Dim i As Long
Dim LR As Long
Dim MyString As String, newString As String
Dim strFolder As String, strFile As String
Dim rng
Dim iPage As Integer

Dim myRange As Range
Dim MyCell As Range
Dim splitText As Variant
Dim Ws As Worksheet

Set ws2 = ThisWorkbook.Worksheets("Defect des_backup")
Set ws3 = ThisWorkbook.Worksheets("Defects")



On Error Resume Next


WordApp.Visible = True

Set oWord = GetObject(, "Word.Application")

oWord.Visible = True

oWord.Activate

strFolder = ActiveWorkbook.Path

strFile = Dir(strFolder & "\" & ThisWorkbook.Worksheets("Defects").Range("H1").value, vbNormal)

Set oDoc = oWord.Documents.Open(Filename:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=True, ReadOnly:=True) ' <= modify according to your path
oWord.Visible = True

With oDoc

Set rng = .GoTo(What:=wdGoToPage, Name:=2)

Set rng = rng.GoTo(What:=wdGoToBookmark, Name:="\page")

rng.delete

End With

Set shtSearchItem = ThisWorkbook.Worksheets("Defects")

If ThisWorkbook.Worksheets.Count < 2 Then

ThisWorkbook.Worksheets.Add After:=shtSearchItem

End If

Set shtExtract = ThisWorkbook.Worksheets("Defect des_backup")

LastRow = ws3.Range("D" & Rows.Count).End(xlUp).Row

CurrRowShtExtract = 2

For CurrRowShtSearchItem = 2 To LastRow


Set oRange = oDoc.Range

With oRange.Find

.Text = shtSearchItem.Cells(CurrRowShtSearchItem, 4).Text

.MatchCase = False

.MatchWholeWord = True

While oRange.Find.Execute = True

oRange.Select

myPara = oDoc.Range(0, oWord.Selection.Paragraphs(1).Next(Count:=2).Range.End).Paragraphs.Count

shtExtract.Cells(CurrRowShtExtract, 1).value = .Text

'shtExtract.Cells(CurrRowShtExtract, 3).Value = myPara

shtExtract.Cells(CurrRowShtExtract, 2) = oDoc.Paragraphs(myPara).Range

oRange.Collapse wdCollapseEnd

Wend

End With

CurrRowShtExtract = CurrRowShtExtract + 1

Next

Set oWord = Nothing

Set oDoc = Nothing


Application.EnableEvents = True
End Sub