Need a macro to create a subdocument

Use a macro containing the following code

Sub MakeSubDoc()
Dim source As Document
Dim target As Document
Dim str As String
Dim rngstr As Range
Set source = ActiveDocument
Set target = Documents.Add
source.Activate
str = InputBox("Insert the text to be found.")
Selection.HomeKey wdStory
Selection.Find.ClearFormatting
With Selection.Find
    Do While .Execute(FindText:=str, MatchWildcards:=False, MatchCase:=True, Wrap:=wdFindStop, Forward:=True) = True
        Set rngstr = Selection.Range.Bookmarks("\line")
        target.Range.InsertAfter rngstr & vbCr
        Selection.Collapse wdCollapseEnd
    Loop
End With
target.Activate
End Sub