Option Explicit 
 
 
Public Function Searchwords(TotParas As Integer, MyTopic2$, Mytopic1$, _ 
    Sourcefile As String, Transferfile As String) As Boolean 
     
     'Extract and transfer range between Word docs. Standard module code
     'Searches Sourcefile for 1 or 2 words in a range defined by...
     'Mytopic1(1st paragraph of range)to Totparas(total # of paras/lines in range)
     '(use 1 for Mytopic2 if only one word search required within range)
     'copies found range(s) to Transferfile
     'uses file copies to prevent/correct open file errors
     '** paragraphs are 1 line only
     
     'TotParas= # of paragraphs/lines in range to be transferred
     'MyTopic2$= 2nd word to be found located anywhere within range.
     'Mytopic1$= 1st word to be found. **Must be in 1st paragraph of range
     'Sourcefile= Doc file being searched
     'Transferfile= Doc file that range is being transferred to
     'Boolean result indicates success/failure of transfer
     
    Dim Wapp As Object, Bigstring As String 
    Dim Mydata$, Temp As String, PagFlag As Boolean 
    Dim Myrange As Variant, Myrange2 As Variant, Adjust As Integer 
    Dim ThisParaLoc As Integer, LastParaLoc As Integer, FirstParaloc As Integer 
     
    Searchwords = True 
     
     'copy scource file to temp file & error check
    If NoFileError(Sourcefile) Then 
        Exit Function 
    End If 
     
    On Error GoTo RetErr 
     'Open source temp file and search
    Set Wapp = CreateObject("Word.Application") 
    Temp = Left(Sourcefile, Len(Sourcefile) - 4) & "T.doc" 
    Wapp.documents.Open Filename:=Temp, ReadOnly:=True 
     
    ThisParaLoc = 0 'found paragraph line#
    Bigstring = vbNullString 'combines paragraphs
     
     'turn on pagination
    PagFlag = False 
    If Wapp.Options.Pagination = False Then 
        Wapp.Options.Pagination = True 
        PagFlag = True 
    End If 
     
     'find last paragraph
    Wapp.activedocument.Select 
    LastParaLoc = Wapp.Selection.paragraphs.Count 'last paragraph(line#)
     
     'Find keyword(MyTopic1) in the source WORD document
     'loop to find all keywords in doc.
    On Error GoTo RetErr2 
    Do While ThisParaLoc < LastParaLoc 
        Set Myrange2 = Wapp.activedocument.paragraphs(ThisParaLoc + 1).Range 
        Myrange2.SetRange Start:=Myrange2.Start, _ 
        End:=Wapp.activedocument.paragraphs(LastParaLoc).Range.End 
        Myrange2.Select 
        With Wapp.Selection.Find 
            .Text = Mytopic1 
            .Forward = True 
            .Execute 
             
            If .found = True Then 
                On Error GoTo RetErr3 
                 
                 'if > 1 page
                If Wapp.Selection.Information(3) > 1 Then 
                    Adjust = Wapp.Selection.Information(3) * 46 - 46 
                End If 
                 
                 'expand keyword selection to whole paragraph(line) selection
                .Parent.Expand Unit:=4 
                 
                 'expange range to include total # of paragraphs/lines
                FirstParaloc = Wapp.Selection.Information(10) + Adjust 
                Set Myrange = Wapp.activedocument.paragraphs(FirstParaloc).Range 
                Myrange.SetRange Start:=Myrange.Start, _ 
                End:=Wapp.activedocument.paragraphs(FirstParaloc + _ 
                (TotParas - 1)).Range.End 
                ThisParaLoc = FirstParaloc + (TotParas - 1) 
                Myrange.Select 
                 
                 'find 2nd keyword
                If MyTopic2 <> "1" Then 
                    Myrange.Select 
                    With Wapp.Selection.Find 
                        .Text = MyTopic2 
                        .Forward = True 
                        .Execute 
                    End With 
                     
                    If .found = True Then 
                        Myrange.Select 
                        Mydata = Wapp.Selection.Text 
                    Else 
                        GoTo Below 'Mytopic2 not found
                    End If 
                     
                End If 
                 'found paragraph range converted to string
                Mydata = Wapp.Selection.Text 
            Else 
                Exit Do 'Mytopic1 not found
            End If 
             
        End With 
         
         'store found paragraph range with other found ranges
        Bigstring = Bigstring + Mydata 
         
Below: 
    Loop 
     
    On Error GoTo RetErr4 
     'transfer file to temp file & error check
    NoFileError (Transferfile) 
     
     'temp transfer file to real transfer file (errorcheck/correct)
    BackToReal Transferfile, False 
     
     'transfer from bigstring to transfer file
    Wapp.documents.Open Filename:=Transferfile, ReadOnly:=False 
    Wapp.activedocument.Select 
    With Wapp.activedocument 
        .Range(0, .Characters.Count).Delete 
        .content.insertafter Bigstring 
    End With 
    Wapp.activedocument.Close savechanges:=True 
     
     'reset pagination to start setting
    If PagFlag Then 
        Wapp.Options.Pagination = False 
    End If 
     
    Wapp.Quit 
    Set Wapp = Nothing 
     
     'temp source file to real file
    BackToReal Sourcefile, True 
     
    Exit Function 
     
     'handle errors
    RetErr:     On Error GoTo 0: MsgBox "Source Doc Error": Kill Temp: GoTo Erbelow 
    RetErr2:     On Error GoTo 0: MsgBox "Search Error": Kill Temp: GoTo Erbelow 
    RetErr3:     On Error GoTo 0: MsgBox "Range Creation Error": Kill Temp: GoTo Erbelow 
    RetErr4:     On Error GoTo 0: MsgBox "Transfer Doc Error": Kill Temp: Kill _ 
    Left(Transferfile, Len(Transferfile) - 4) & "T.doc" 
     
Erbelow: 
    Searchwords = False 
     'reset pagination to start setting
    If PagFlag Then 
        Wapp.Options.Pagination = False 
    End If 
    Wapp.Quit 
    Set Wapp = Nothing 
     
End Function 
 
Function NoFileError(Flpath As String) As Boolean 
     'check if file exists. Copy to temp file from real file
    Dim fs As Object, TemP3 As String 
    Set fs = CreateObject("Scripting.FileSystemObject") 
    If fs.fileexists(Flpath) Then 
        TemP3 = Left(Flpath, Len(Flpath) - 4) & "T.doc" 
        fs.copyfile Flpath, TemP3 
        NoFileError = False 
    Else 
        On Error GoTo 0 
        MsgBox "Error: This file does not exist: " & Flpath 
        NoFileError = True 
    End If 
    Set fs = Nothing 
End Function 
 
Function BackToReal(Retpath As String, FlScource As Boolean) 
     'if real source file open continue (leave source file open)
     'if real transfer file open, close it and continue
     'copy temp file back to real file & kill temp file
    Dim fs As Object, Objwordapp As Object, d As Variant, TemP2 As String 
    TemP2 = Left(Retpath, Len(Retpath) - 4) & "T.doc" 
    Set fs = CreateObject("Scripting.FileSystemObject") 
    On Error GoTo Errcode 
    fs.copyfile TemP2, Retpath 
    Set fs = Nothing 
    Kill TemP2 
    Exit Function 
     
Errcode: 
    On Error GoTo 0 
    If FlScource Then 
        MsgBox "Transfer proceeding. This source file remains open:  " & Retpath 
    Else 
        MsgBox "Close all Word Docs. Transfer proceeding. This transfer file was open:  " & Retpath 
        Set Objwordapp = GetObject(, "word.application") 
        With Objwordapp 
            .Application.Quit 
        End With 
        Set Objwordapp = Nothing 
        fs.copyfile TemP2, Retpath 
    End If 
    Set fs = Nothing 
    Kill TemP2 
End Function 
 
Sub Callfunction() 
     
    Dim TParas As Integer, MyTop1 As String, Mytop2 As String 
    Dim Sfile As String, Tfile As String 
     
    Sfile = "c:\vbaxtest.doc" 'search document path
    Tfile = "c:\test.doc" 'search results document path
     'other search words as Mytop1 eg's: Assert,spraysup,CustAPL,RndUp
    MyTop1 = "seed" ' 1st search word ie. start of transfer range
     
     'other search eg. trial "bart" as Mytop2 with "seed" as mytop1
    Mytop2 = "1" ' 2nd search word. Set to "1" if only 1 word search
    TParas = 5 '# of paras to extract (includes blank para following range)
     
    If Searchwords(TParas, Mytop2, MyTop1, Sfile, Tfile) Then 
        MsgBox "Transfer complete" 
    Else 
        MsgBox "Transfer not successful" 
    End If 
End Sub