用VBA将一个Word文档中符合某些条件的内容抽取到另一个文档中

如下图，有一份大纲级别定义良好的Word文档：

图中“JZ”开头的蓝色底纹段落样式为“标题 2”，数字序号开头的灰色底纹段落样式为“标题 3”，“答：”开头的无底纹段落样式为“正文”。每个标题3段落的末尾有不同数量的星（★），如果我们要将所有四星以上的问题和答案以及该问题所属的主题（标题2段落）抽取出来，保存到另一个文件中，该怎么做？

操作步骤：先创建一个新文档，再在源文档中查找“★★★★”，每次定位到一个问题，然后选择该问题及答案→复制→激活新文档→光标定位到新文档末尾→粘贴，直至复制完全部内容。

当然无需手工执行上述操作，可以用VBA自动化，代码如下：

Sub 提取文档部分内容()

     Dim selPos As Long, Path$, rng As Range, titPara As Range
     Dim newDoc As Document, mainDoc As Document, olLevel%
     Path = "F:\源文档.docx"
     Set mainDoc = Documents(Path) '源文档对象
     Set newDoc = Documents.Add '创建新文档
     olLevel = 3 '指定提取内容的大纲级别，样式“标题 3”的大纲级别为3
     selPos = 0 '用于记录光标位置，其数据类型要足够大（超过10页A4就建议用Long），以免文档太长突破其上限导致最后陷入死循环
     Application.ScreenUpdating = False
     mainDoc.Activate '源文档预先打开，将其激活
     With Selection
        ' 光标移动至原文档开头
        .HomeKey Unit:=wdStory
        Do
            If .Paragraphs(1).outlineLevel <= olLevel Then '根据大纲级别定位原文档分割位置
                Set titPara = .Paragraphs(1).Range
                
                If InStr(1, titPara.Text, "★★★★") > 0 Or .Paragraphs(1).outlineLevel = 2 Then
                    If .Paragraphs(1).outlineLevel = 2 Then
                        titPara.Copy '复制标题2段落的内容
                    Else
                        Set rng = .Bookmarks("\headinglevel").Range '获取该标题下所有内容
                        rng.Copy '复制标题3段落及其所属正文段落内容
                    End If
                    With newDoc.ActiveWindow.Selection '进入新文档
                        .EndOf wdStory '光标移动到新文档末尾
                        .Paste '粘贴复制的内容
                    End With
                End If
            End If
            With mainDoc.ActiveWindow.Selection '进入源文档
                selPos = .Start '记录光标位置
                .GoTo wdGoToHeading, wdGoToNext, 1 '光标移动到下一个标题
                If selPos = .Start Then '执行GoTo方法后光标位置未发生变化，则已遍历完文档中的全部标题
                    If selPos = 0 Then MsgBox "文档中没有标题"
                    Exit Do
                End If
            End With
        Loop
    End With
    Set newDoc = Nothing
    Set mainDoc = Nothing
    Set rng = Nothing
    MsgBox "处理完成。"
    Application.ScreenUpdating = True
End Sub

下面提供一个无需在原文档和新文档之间反复切换活动文档的方法：

Sub 提取文档部分内容()
 
     Dim selPos As Long, Path$, rng As Range, titPara As Range
     Dim newDoc As Document, olLevel%, copied As Boolean
     
     olLevel = 3 '指定提取内容的大纲级别，样式“标题 3”的大纲级别为3
     selPos = 0 '用于记录光标位置，其数据类型要足够大（超过10页A4就建议用Long），以免文档太长突破其上限导致最后陷入死循环
     copied = False '是否复制了文档内容的标志
     Application.ScreenUpdating = False
     ' 先清除文档中的可编辑区域
     ActiveDocument.DeleteAllEditableRanges wdEditorEveryone
     With Selection
        ' 光标移动至原文档开头
        .HomeKey Unit:=wdStory
        Do
            selPos = .Start '记录光标位置
            .GoTo wdGoToHeading, wdGoToNext, 1 '光标移动到下一个标题
            If selPos = .Start Then '执行GoTo方法后光标位置未发生变化，则已遍历完文档中的全部标题
                If selPos = 0 Then
                    MsgBox "文档中没有标题"
                    Exit Sub
                End If
                Exit Do
            End If
            If .Paragraphs(1).OutlineLevel <= olLevel Then ' 根据大纲级别定位原文档分割位置
                Set titPara = .Paragraphs(1).Range
                
                If InStr(1, titPara.Text, "★★★★") > 0 Then ' 判断当前内容是否符合要求
                   Set rng = .Bookmarks("\headinglevel").Range ' 获取该标题下所有内容
                   rng.Editors.Add wdEditorEveryone ' 将符合要求的内容假如可编辑区域
                End If
            End If
        Loop
        ' 选择文档中的所有可编辑区域
        ActiveDocument.SelectAllEditableRanges wdEditorEveryone
        If .Start <> .End Then ' 文档中存在选区
            .Copy ' 复制内容
            copied = True ' 设置复制标志
        End If
        ActiveDocument.DeleteAllEditableRanges wdEditorEveryone
        If copied Then ' 复制了内容，则创建新文档，并粘贴复制的内容
            Set newDoc = Documents.Add
            newDoc.Content.Paste
        End If
    End With
    Set newDoc = Nothing
    Set rng = Nothing
    MsgBox "处理完成。"
    Application.ScreenUpdating = True
End Sub