Copy from point to point if object exists within points

[grojom]

What I want specifically is for a macro that will loop through my document, and copy from "REQUESTS FOR PRODUCTION" till the next occurance of "REQUESTS FOR PRODUCTION" but only if the word "Object" exists within that section. And for all the new copy to be moved to a new document.

Here is some source txt

REQUESTS FOR PRODUCTION NO. 1: blah blah unimportant text that goes on and on
RESPONSE: Object - some stuff here
REQUESTS FOR PRODUCTION NO. 2: blah blah blah
RESPONSE: Invalid - some stuff here
REQUESTS FOR PRODUCTION NO. 3: blah blah blah
RESPONSE: Object - some stuff here

I found this bit of code and it almost works, however does not copy until the next section and I do not know how to write the if statement for if "object" exists.

Sub CopyParas()
Selection.Find.ClearFormatting
With Selection.Find
.Text = "REQUESTS FOR PRODUCTION"
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Do While Selection.Find.Execute
Selection.StartOf Unit:=wdParagraph
Selection.MoveEnd Unit:=wdParagraph
sBigString = sBigString + Selection.Text
Selection.MoveStart Unit:=wdParagraph
Loop
Documents.Add DocumentType:=wdNewBlankDocument
Selection.InsertAfter (sBigString)
End Sub

My end result (in case I have not been specific enough) based upon my sample text above should look like this, in a new document.

REQUESTS FOR PRODUCTION NO. 1: blah blah unimportant text that goes on and on
RESPONSE: Object - some stuff here

REQUESTS FOR PRODUCTION NO. 3: blah blah blah
RESPONSE: Object - some stuff here
I will eventually need to put more text before and after this so if I should be using a template or something to that effect any advise there is welcomed as well.

Thank you in advance for your time.

[grojom]

Did I ask a stupid question or a really hard one?

[Tinbendr]

Patience! Beggars can't be choosers.

Sub SelectPhrases2()
Dim aDoc As Document
Dim bDoc As Document
Dim Rng1 As Range
Dim Rng2 As Range
Dim Rng3 As Range
Set aDoc = ActiveDocument
Set bDoc = Documents.Add
Set Rng1 = aDoc.Range
Set Rng2 = Rng1.Duplicate
Set Rng3 = Rng1.Duplicate
Do
With Rng1.Find
.Text = "REQUESTS FOR PRODUCTION"
.Format = False
.Forward = True
.MatchWholeWord = False
.MatchWildcards = False
.Execute
End With
If Rng1.Find.Found Then
Rng2.Start = Rng1.End + 1

With Rng2.Find
.Text = "REQUESTS FOR PRODUCTION"
.Format = False
.Forward = True
.MatchWholeWord = False
.MatchWildcards = False
.Execute
End With
If Rng2.Find.Found Then
Set Rng3 = aDoc.Range(Rng1.Start, Rng2.Start - 1)
If InStr(Rng3.Text, "RESPONSE: Object") Then
bDoc.Range.FormattedText.InsertAfter Rng3 & vbCr
bDoc.Range.Collapse wdCollapseEnd
End If
End If
End If
Loop Until Not Rng1.Find.Found

End Sub

[Tinbendr]

Opps, forgot the last section.

Sub SelectPhrases2()
Dim aDoc As Document
Dim bDoc As Document
Dim Rng1 As Range
Dim Rng2 As Range
Dim Rng3 As Range
Set aDoc = ActiveDocument
Set bDoc = Documents.Add
Set Rng1 = aDoc.Range
Set Rng2 = Rng1.Duplicate
Set Rng3 = Rng1.Duplicate
Do
With Rng1.Find
.Text = "REQUESTS FOR PRODUCTION"
.Format = False
.Forward = True
.MatchWholeWord = False
.MatchWildcards = False
.Execute
End With
If Rng1.Find.Found Then
Rng2.Start = Rng1.End + 1

With Rng2.Find
.Text = "REQUESTS FOR PRODUCTION"
.Format = False
.Forward = True
.MatchWholeWord = False
.MatchWildcards = False
.Execute
End With
If Rng2.Find.Found Then
Set Rng3 = aDoc.Range(Rng1.Start, Rng2.Start - 1)
If InStr(Rng3.Text, "RESPONSE: Object") Then
bDoc.Range.FormattedText.InsertAfter Rng3 & vbCr
bDoc.Range.Collapse wdCollapseEnd
End If
Rng1.Start = Rng1.End + 1
Else
Set Rng3 = aDoc.Range(Rng1.Start, aDoc.Range.End)
If InStr(Rng3.Text, "RESPONSE: Object") Then
bDoc.Range.FormattedText.InsertAfter Rng3 & vbCr
bDoc.Range.Collapse wdCollapseEnd
End If
Rng1.Start = Rng1.End + 1
End If

End If
Loop Until Not Rng1.Find.Found

End Sub