如何通过代码做到将多处选定的关键字所在段落提取到新文档？

tangqingfu

请教如何通过代码做到将多处选取的关键字所在段落提取到新文档，提取后保留原有格式（如字体，颜色等）
以下是小花鹿老师帮忙编写的代码，可惜处理一处关键字请教如何做到将（处于同一段落的）多处选取的关键字（不连续的关键字）所在的段落提取到新文档中如一处关键字在在单词中，另一处关键字在音标中
Sub 提取关键字所在段落到新文档中()
   Dim mydoc As Document, p As Range, s, thisdoc As Document
    If Selection.Type = wdSelectionIP Then
        MsgBox "您未选择关键字，请选择关键字后再运行程序！": Exit Sub
    Else
        s = Selection.Text
    End If
    Set thisdoc = ActiveDocument
    Set mydoc = Documents.Add
    With thisdoc.Content.Find
        .ClearFormatting
        .Text = s
        Do While .Execute
            Set p = .Parent.Paragraphs(1).Range.FormattedText
            With mydoc.Range
                .Collapse wdCollapseEnd
                .FormattedText = p
            End With
            .Parent.Move 4
        Loop
    End With
End Sub

413191246se

唐兄：小花鹿老师的程序运行没问题，你的意思是，要同时选择多处关键字？我看只能是选择一处，运行一下程序，可以将宏设置为热键 F3 或 F8。

tangqingfu

413191246se 发表于 2021-5-12 15:19
唐兄：小花鹿老师的程序运行没问题，你的意思是，要同时选择多处关键字？我看只能是选择一处，运行一下程序 ...

对，是同时选择多处关键字

413191246se

唐兄：建议还是将宏设置热键 F3 或 F8，点选一处，按一下热键，速度很快，程序也不必修改。

tangqingfu

413191246se 发表于 2021-5-12 16:59
唐兄：建议还是将宏设置热键 F3 或 F8，点选一处，按一下热键，速度很快，程序也不必修改。

这样时效会差些，主要是要想快速精确选择，413191246se兄能否指点下？

413191246se

唐兄：指点不敢当！同一段落选取关键字会提取到很多重复段落；另外，程序中查找不连续字符，必须得做个记号，如变红或加下划线，否则，程序只能记住最后一处选定字词。