From Excel, selecting Word text between headings

[davidbhill]

I've been programming a long time, the last ten years mostly with Access VBA. I have ventured into Word and Excel VBA a few times, but not much. So I am embarrassed to admit I'm stumped.

I'm currently working in Office 2013.

I have a list of documents and the headings within each document. The headings are unique within each document.

I want to select the text between headings, place it into a string variable, then search the string variable for various words. My thought was I can use the list of headings to find a starting point and select all the text between that point and the next heading. It was not obvious to me how to do that so I have been searching the internet for code examples and modified it to fit my environment.

Here's the code I have so far. It is incomplete. I have commented out a couple of loops because they won't work until I get the selection problem resolved.

Sub search_docs_2()

' This subroutine reads through the list of document headings.

' Each section of content between headers is searched using the keywords selected
' in the "Key Words" worksheet. For each keyword found, the priority value (from column D)
' is added to the total score for that section.

' After all documents are searched, the document sections are sorted from highest score to lowest
' score. The presumption is that a section with a high search score is more likely to be relavent
' to the original requirement.

Dim Ctr As Long
Dim MyData As DataObject
Dim docSource As Word.Document
Dim SearchText, sPath, sDoc, sSource As String
Dim BegHead, EndHead, DocOpen As String
Dim appwd As Object
Dim test1, test2, test3 As String

Set MyData = New DataObject
Set appwd = CreateObject("Word.Application")
DocOpen = "N"

' cell E1 on sheet "Search Results" contains number of rows to process
For x = 2 To Sheets("Search Results").Range("E1").Value
 
    ' if document name changed, close old doc and open new one
    If Sheets("Search Results").Range("$A" & x).Value <> Sheets("Search Results").Range("$A" & x - 1).Value Then
        If DocOpen = "Y" Then
            docSource.Close (False)
        End If
        sPath = "C:\Users\dhhill\Documents\RTM Search Folder\"
        sDoc = Sheets("Search Results").Range("$A" & x).Value
        sSource = sPath & sDoc
        Set docSource = Word.Documents.Open(sSource, , True)
        DocOpen = "Y"
    End If
    
    ' get beginning and ending headings - end of document is marked with string "9999999999999999"
    BegHead = Sheets("Search Results").Range("$B" & x).Value
    If Sheets("Search Results").Range("$A" & x).Value = Sheets("Search Results").Range("$A" & x + 1).Value Then
        EndHead = Sheets("Search Results").Range("$B" & x + 1).Value
    Else
        EndHead = "9999999999999999"
    End If
    
     'Find first heading (equivalent to the Word FIND command)
     'Sets the parameters
    With docSource.Range.Find
        .ClearFormatting
        .Text = BegHead
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
     'Execute the command
    docSource.Range.Find.Execute
test1 = docSource.Range.Text
     'The first heading text is selected
     'Set the cursor at the beginning of the next line
    docSource.Range.Next Unit:=wdParagraph, Count:=1
test2 = docSource.Range.Text
     'selects the whole paragraph
    docSource.Range.Next Unit:=wdParagraph, Count:=1
test3 = docSource.Range.Text
     'Loops through and counting paragraphs until text equal to second heading
     'string compared is equal to paragraph text length -1 to suppress paragraph mark
'    Do Until Left(docSource.Range.Text, Len(docSource.Range.Text) - 1) = EndHead
'        Ctr = Ctr + 1
'        docSource.Range.Next Unit:=wdParagraph, Count:=1
'    Loop
     'Positions again under "Heading 1"
    With docSource.Range.Find
        .ClearFormatting
        .Text = BegHead
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
    End With
    docSource.Range.Find.Execute
    docSource.Range.Move Unit:=wdParagraph, Count:=1
     'Selects the number of paragraphs counted above
'    For i = 1 To Ctr - 1
'        docSource.Range.Move Unit:=wdParagraph, Count:=1
'    Next I
     'Copies them
    docSource.Range.Copy
    ' Puts clipboard text in variable
    MyData.GetFromClipboard
    SearchText = MyData.GetText(1)
Next x

End Sub

I threw in a few "testx" strings to view the results of the Range.Find, Range.Move, and Range.Next lines. All I seem to be doing is getting the text at the beginning of the document before any headings.

If I have not explained the problem clearly let me know. If my approach is all wrong, let me know. If you can help me, I will be very grateful.

thanks,
David

[Leith Ross]

Hello David,

Can you upload of a copy of the word document to a public file sharing site? It would be nice to have in order to test the code with.

[davidbhill]

Hello David,

Can you upload of a copy of the word document to a public file sharing site? It would be nice to have in order to test the code with.

Sorry, I can't. Both the format and the content are proprietary. I know it would be nice, but I will have to settle for some advice on methods and properties regarding the search.

It should be fairly simple to construct a test document. Just have three headings interspersed with text, then open the Word doc from Excel and select the text between two headings.

[Leith Ross]

Hello David,

Try this macro out. It looks for headings with the style "Heading 1". You can change this to match the style of the headings in your document.

Sub GetTextBetweenHeadings()
    Dim colPara As New Collection
    Dim Doc     As Document
    Dim n       As Long
    Dim Text    As String
    Set Doc = ActiveDocument
    For n = 1 To Doc.Paragraphs.Count - 1
        If Doc.Paragraphs(n).Style.NameLocal = "Heading 1" Then
            colPara.Add Doc.Paragraphs(n).Range
        End If
    Next n
    For n = 1 To colPara.Count
        On Error Resume Next
        Text = Doc.Range(colPara(n).End, colPara(n + 1).Start - 1).Text
        If Err = 9 Then
            Text = Doc.Range(colPara(n).End, Doc.Content.End).Text
        End If
        On Error GoTo 0
        MsgBox Text
    Next n
End Sub