select a range of text from one Word document and copy into another Word document

Question

I'm trying to use VBA to extract sentences in one Word document and put it into another Word document. So for example, if we need to find the title of the organization, we follow the algorithm:

Search for "Title"
Do (Take) each character after "Title" and (stop) until "Address"

Answer 1

The following works but there may be a more efficient way of doing this:

Sub FindIt()
    Dim blnFound As Boolean
    Dim rng1 As Range
    Dim rng2 As Range
    Dim rngFound As Range
    Dim strTheText As String

    Application.ScreenUpdating = False
    Selection.HomeKey wdStory
    Selection.Find.Text = "Title"
    blnFound = Selection.Find.Execute
    If blnFound Then
        Selection.MoveRight wdWord
        Set rng1 = Selection.Range
        Selection.Find.Text = "Address"
        blnFound = Selection.Find.Execute
        If blnFound Then
            Set rng2 = Selection.Range
            Set rngFound = ActiveDocument.Range(rng1.Start, rng2.Start)
            strTheText = rngFound.Text
            MsgBox strTheText
        End If
    End If
    'move back to beginning
    Selection.HomeKey wdStory
    Application.ScreenUpdating = True
End Sub

You can switch between documents using Activate, preferably using object variables.

Microsoft MVP Jay Freedman kindly revised this for me to work without the Selection object, making it much neater.

Sub RevisedFindIt()
' Purpose: display the text between (but not including)
' the words "Title" and "Address" if they both appear.
    Dim rng1 As Range
    Dim rng2 As Range
    Dim strTheText As String

    Set rng1 = ActiveDocument.Range
    If rng1.Find.Execute(FindText:="Title") Then
        Set rng2 = ActiveDocument.Range(rng1.End, ActiveDocument.Range.End)
        If rng2.Find.Execute(FindText:="Address") Then
            strTheText = ActiveDocument.Range(rng1.End, rng2.Start).Text
            MsgBox strTheText
        End If
    End If
End Sub

The only remaining requirement is to get this text into the other document. Something like:

Documents(2).Range.Text = strTheText

Answer 2

This code will write to external file:

Sub RevisedFindIt_savetofile2 () 
' Purpose: display the text between (but not including)
' the words "Title" and "Address" if they both appear.
'This file will search current document only, the data in open word document.
Dim rng1 As Range
Dim rng2 As Range
Dim strTheText As String
Dim DestFileNum As Long
Dim sDestFile As String

sDestFile = "C:\test-folder\f12.txt" 'Location of external file
DestFileNum = FreeFile()
'A valid file number in the range 1 to 511,
'inclusive. Use the FreeFile function to obtain the next available file number.

Open sDestFile For Output As DestFileNum 'This opens new file with name DestFileNum
Set rng1 = ActiveDocument.Range
If rng1.Find.Execute(FindText:="Title") Then
    Set rng2 = ActiveDocument.Range(rng1.End, ActiveDocument.Range.End)
    If rng2.Find.Execute(FindText:="Address") Then
        strTheText = ActiveDocument.Range(rng1.End, rng2.Start).Text
        MsgBox strTheText 'writes string to a message box
        Print #DestFileNum, strTheText 'Print # will write to external file with the text strTheText
    End If
End If
Close #DestFileNum 'Close the destination file
End Sub