定位到指定关键词的行，并且删除所在行直到文档末尾的内容

ofaye

文件夹中有多个word文档。现在想做如下操作。查找并定位如下任何一个关键词:
还看了
猜你喜欢
相关文章
你感兴趣的

定位到指定关键词的行，并且删除所在行直到文档末尾的内容
请各位大神帮帮忙，谢谢啦

413191246se

1. Sub Word2007循环遍历文件夹()
   
2. '注意：仅处理文件夹（不包含子文件夹）
   
3.     Dim i$, p$, n&
   
4.     p = "E:\abc" '此路径自己改(两个斜杠不要删除！)
   
5.     i = Dir(p & "*.docx")
   
6.     Do While i <> ""
   
7.         Documents.Open FileName:=p & i '打开文档
   
8.         删除关键词所在行至文档末尾内容 '单个文档处理(将处理单个文档的宏名粘贴到这里)
   
9.         ActiveDocument.Close savechanges:=wdSaveChanges '关闭并保存文档
   
10.         n = n + 1
    
11.         i = Dir
    
12.     Loop
    
13.     MsgBox "共处理 " & n & " 个文档！", 0 + 48
    
14. End Sub
    
15. Sub 删除关键词所在行至文档末尾内容()
    
16.     Dim a, i&, doc As Document
    
17.     Set doc = ActiveDocument
    
18.     a = Array("还看了", "猜你喜欢", "相关文章", "你感兴趣的")
    
19.     With doc.Content.Find
    
20.         .ClearFormatting
    
21.         For i = 0 To 3 '搜索 4 个词，这里就写 3；如果搜索 8 个词，就写 7
    
22.             .Text = a(i)
    
23.             .Execute
    
24.             If .Found = True Then
    
25.                 .Parent.Font.Color = wdColorRed '红色（此行语句可以删除）
    
26.                 doc.Range(Start:=.Parent.Paragraphs(1).Range.Start, End:=doc.Content.End).Delete
    
27.                 .Parent.Start = doc.Content.Start
    
28.             End If
    
29.         Next i
    
30.     End With
    
31. End Sub

复制代码

ofaye

非常好用谢谢。