word 选中带有关键词的段落

xzcdcak

#在这里快速回复#学习了。不错。不错。

守候_CJ

提取含有某一关键词的所有段落到新文档展示

1. Sub 提取含有某一关键词的所有段落()
   
2.     Dim adoc As Document
   
3.     Dim newDoc As Document
   
4.     Dim pa As Paragraph
   
5.     Dim s As String
   
6.     Dim i As Long
   
7.     Dim t0 As Single
   
8.    
   
9.     t0 = Timer
   
10.     s = InputBox("请输入您的关键词（支持Word通配符）：")
    
11.     If s = "" Then
    
12.         MsgBox "关键词为空，将退出程序！"
    
13.         Exit Sub
    
14.     End If
    
15.     Set adoc = ActiveDocument
    
16.     Set newDoc = Documents.Add
    
17.     i = 0
    
18.    
    
19.     For Each pa In adoc.Paragraphs
    
20.         pa.Range.Find.ClearFormatting
    
21.         If pa.Range.Find.Execute(findtext:=s, Forward:=True, MatchWildcards:=True, Wrap:=wdFindStop) Then
    
22.             i = i + 1
    
23.             pa.Range.Copy
    
24.             newDoc.Paragraphs.Last.Range.Select
    
25.             With Selection
    
26.                 .Collapse 0
    
27.                 .PasteAndFormat (wdFormatOriginalFormatting)
    
28.             End With
    
29.             'newDoc.Paragraphs.Last.Range.InsertAfter Chr(13)
    
30.         End If
    
31.     Next
    
32.    
    
33.     newDoc.Paragraphs.Last.Range.Delete
    
34.     MsgBox Format(i, "共0段，") & Format(Timer - t0, "提取完成！用时0.000秒！")
    
35.     newDoc.Windows(1).Activate
    
36.     Set adoc = Nothing
    
37.     Set newDoc = Nothing
    
38. End Sub

复制代码