查找word文件中章节的标题，并使用VBA将各个段落复制到新的word文件中

Question

由于没有人能够帮助我解决我之前发布的问题（链接在下面），我现在正试图通过VBA解决这个问题。

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

简要回顾一下，我有大量的word文件，我希望每个文件都可以减少到更可读的大小。在每个文件中，有一个标题出现多次，始终形成为“标题2”。我在文档中查找了多次出现的特定标题，我想在这些章节中复制所有文本部分，并将相应的标题复制到新的word文档中。

我决定创建一个excel文件，在其中列出文件以及我要复制的章节的相应标题（见下图）。

要做到这一点，我现在写了以下代码：

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

但是我真的很挣扎。它似乎不起作用，因为我经常遇到命令错误（RunTimeError 438）：

Selection.HomeKey Unit:=wdStory

我知道我必须在引用中激活Microsoft Word 15.0对象库才能获得word命令。然而它没有用。

我非常感谢任何帮助，当然我也对其他建议持开放态度。

单词文件看起来如下图所示，但是我要提取的章节可以在一个word文档中多次出现。因此，我的代码可能需要循环或其他东西，我无法完成此操作。

此外，我还考虑了以下主题链接：

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

我理解正确吗？以下代码是我认为您要尝试执行的操作的核心。它找到第一个标题2，然后找到其后的所有段落，直到找到另一个任何类型的标题或文档末尾。 startCopyRange和endCopyRange是这些段落的范围。您必须将其放入Excel例程中。

一些注意事项。始终将活动文档保存到变量并从中进行操作；然后，该例程运行时，用户可以自由更改活动文档。从不使用选择，而始终使用范围。永远不要使用诸如Move之类的相对动作，总是使用API​​调用。

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