Finding heading of chapters in word file and copying individual paragraphs to new word file with VBA

Question

Since nobody was able to help me with the problem I posted here before (link is below), I am now trying to solve the task through VBA.

Finding a heading in word file and copying entire paragraph thereafter to new word file with python

To briefly recap, I have a large amount of word files, which I would like to reduce to a more readable size each. In each file, there is one heading that appears several times, always formated as a 'Heading 2'. I look for this specific heading which occurs several times in a document and I want to copy all the text parts in just these chapters with the respective heading to a new word document.

I decided to create an excel file in which I list the files and the respective heading of the chapters that I want to copy (see picture below).

To do this now I have written the following code:

Sub SelectData()

    Application.ScreenUpdating = False

    Dim WdApp As Word.Application
    Set WdApp = CreateObject("Word.Application")

    Dim Doc As Word.Document
    Dim NewDoc As Word.Document

    Dim HeadingToFind As String
    Dim ChapterToFind As String
    Dim StartRange As Long
    Dim EndRange As Long

    Dim WkSht As Worksheet

    Dim LRow As Long
    Dim i As Long

    Set WkSht = ThisWorkbook.Sheets("Sheet1")
    LRow = WkSht.UsedRange.Cells.SpecialCells(xlCellTypeLastCell).Row

    With WkSht
        For i = 1 To LRow
            If Dir(.Cells(i, 1).Text, vbNormal) = "" Then
                .Cells(i, 3).Value = "Please check File Location"
            Else
                Set Doc = WdApp.Documents.Open(Filename:=.Cells(i, 1).Text, _
                AddToRecentFiles:=False, Visible:=False, ReadOnly:=False)

                Set NewDoc = Documents.Add

                ChapterToFind = LCase(.Cells(i, 2).Text)

                    With Doc

                    Selection.HomeKey Unit:=wdStory

                        With Selection

                            With .Find
                                .ClearFormatting
                                .Text = ChapterToFind
                                .MatchWildcards = False
                                .MatchCase = True
                                .Execute
                            End With

                            If .Find.Found Then
                                .Collapse wdCollapseStart
                                With .Find
                                    .Text = ""
                                    .Style = "Heading 2"
                                    .Forward = False
                                    .Execute
                                End With

                                .MoveDown Count:=1
                                .HomeKey Unit:=wdLine
                                StartRange = .Start


                                .Find.Forward = True
                                .Find.Execute
                                .Collapse wdCollapseStart
                                .MoveUp Count:=1
                                .EndKey Unit:=wdLine
                                EndRange = .End

                                Doc.Range(StartRange, EndRange).Copy
                                NewDoc.Content.Paste
                                NewDoc.SaveAs2 Doc.Path & "Clean" & ".docx", wdFormatFlatXML
                            Else
                                WkSht.Cells(i, 4).Value = "Error Chapter Not Found"
                            End If

                        End With

                End With
                WdApp.Quit
                Set Doc = Nothing: Set NewDoc = Nothing: Set WdApp = Nothing: Set WkSht = Nothing
                Application.ScreenUpdating = True

            End If

        Next

    End With

End Sub

However I am really struggling. It seems to not work as I constantly get an error with the command (RunTimeError 438):

Selection.HomeKey Unit:=wdStory

I am aware that I have to activate the Microsoft Word 15.0 Object Library in the references to be able to get word commands. Nevertheless it is not working.

I would greatly appreciate any help, I am also open to other suggestions of course.

The word files look something like in the picture below, however the chapter that I want to extract can occur several times within one word document. As a result my code would probably need a loop or something, I was not able to get this done.

Also I have considered the following links to the topic:

Use VBA with Powerpoint to Search titles in a Word Doc and Copy Text into another Word Document

VBA: open word from excel

word vba: select text between headings

Answer 1

Did I understand this correctly? The following code is the core of what I think you're trying to do. It finds the first Heading 2, then finds all the paragraphs after it until it finds another header of any type or the end of the document. startCopyRange and endCopyRange is the range of those paragraphs. You'll have to piece this into your Excel routine.

A few notes. Always save the active document to a variable and work from that; the user is then free to change active documents while this routine is running. Never use Selection, always use ranges. Never use relative movements like Move, always use API calls.

Sub SelectData()
    Dim Doc As Word.Document
    Set Doc = ActiveDocument

    Dim findRange As Range
    Set findRange = Doc.Range

    ChapterToFind = "My Chapter"
    findRange.Find.Text = ChapterToFind
    findRange.Find.Style = "Heading 2"
    findRange.Find.MatchCase = True

    Dim startCopyRange As Long
    Dim endCopyRange As Long
    Do While findRange.Find.Execute() = True
        startCopyRange = findRange.End + 1
        endCopyRange = -1
        'findRange.Select

        Dim myParagraph As Paragraph
        Set myParagraph = findRange.Paragraphs(1).Next

        Do While Not myParagraph Is Nothing
            myParagraph.Range.Select 'Debug only

            If InStr(myParagraph.Style, "Heading") > 0 Then
                endCopyRange = myParagraph.Range.Start - 0
            End If

            If myParagraph.Next Is Nothing Then
                endCopyRange = myParagraph.Range.End - 0
            End If

            If endCopyRange <> -1 Then
                Doc.Range(startCopyRange, endCopyRange).Select  'Debug only
                DoEvents
                Exit Do
            End If

            Set myParagraph = myParagraph.Next
            DoEvents
        Loop
    Loop
End Sub