求大神，如何快速摘录带有特定文字的段落，去掉其他内容

sylun

也可试试如下代码，自行指定关键词，希望对学习《民法典》有点帮助。

1. Sub test()
   
2.     '仅用于删除民法典中不含特定关键词的条文
   
3.     '文本要求：各编章节号及法条后应有空格（全半角不限），附则标题没空格，其他段落不能有空格
   
4.     Dim i As Integer  '统计有两款及以上内容的法条数
   
5.     Dim n As Integer  '统计含有指定关键词的法条数
   
6.     Dim keyword As String
   
7.    
   
8.     keyword = InputBox("处理后仅保留目录、章节名和包含关键词的条文！", "请输入要标记的关键词", "另有约定")
   
9.     If keyword = Empty Then Exit Sub
   
10.     Application.ScreenUpdating = False
    
11.     With ActiveDocument.Content.Find
    
12.         .Text = "^13第[!^13条]{1,7}条[ 　]"
    
13.         .MatchWildcards = True
    
14.         Do While .Execute
    
15.             With .Parent
    
16.                 If .End < ActiveDocument.Content.Paragraphs.Last.Previous.Range.Start Then
    
17.                     Do While InStr(.Next(wdParagraph, 1).Text, "　") = 0 And InStr(.Next(wdParagraph, 1).Text, " ") = 0 _
    
18.                         And .Next(wdParagraph, 1).Text Like "附则*" = False
    
19.                         .End = .Next(wdParagraph).End
    
20.                     Loop
    
21.                 End If
    
22.                 If .Paragraphs.Count > 2 Then i = i + 1 Else .MoveEnd wdParagraph
    
23.                 If InStr(.Text, keyword) = 0 Then
    
24.                     ActiveDocument.Range(.Start + 1, .End).Delete
    
25. '                    .SetRange .End - 1, .End - 1 '不想删除不含指定关键词的法条时用本行，并去掉上一行
    
26.                 Else
    
27.                     .HighlightColorIndex = wdYellow '突出显示含关键词的法条
    
28.                     .Start = .End - 1
    
29.                     n = n + 1
    
30.                 End If
    
31.                 .Collapse wdCollapseStart
    
32.             End With
    
33.         Loop
    
34.         '以下三行可用于删除民法典中各级标题
    
35. '        .Parent.WholeStory
    
36. '        .Execute findtext:="第[!编章节条]{1,3}[编章节][ 　]*^13", replacewith:="", Replace:=wdReplaceAll
    
37. '        .Execute findtext:="附则^13", replacewith:="", Replace:=wdReplaceOne
    
38.     End With
    
39.     MsgBox "共找到" & n & "个法条含有如下指定的关键词：" & keyword
    
40.     Application.ScreenUpdating = True
    
41. End Sub

复制代码