WORD关键词删除

1308128118

请哪位大咖帮一帮忙，我有一批WORD文档，有doc格式和docx格式的，请哪位大师能帮我把如果在第二至第五段有某关键词（这关键词有好几个：比如校长，班主任，老师等），则关键词所在的行或关键词所在的段落删除，关键词在其他地方不改变

413191246se

* 楼主，请做好原文档备份后试用下面的宏：（注意：不要先打开文档，要先运行宏。请核对是否正确。）

1. Sub DIR_循环遍历文件夹_删除关键词()
   
2. 
   
3.     On Error Resume Next
   
4.     Dim arr, a As Paragraph, j&, r As Range
   
5.     arr = Array("校长", "班主任", "老师")
   
6.     Dim objShell As Object, objFolder As Object, SearchPath$, DicList As Object, FileList As Object, Key, NowDic$, NowFile$, i&, FileName, FilePath, doc As Document, x&
   
7. 
   
8.     Set objShell = CreateObject("Shell.Application")
   
9.     Set objFolder = objShell.BrowseForFolder(0, "请选择文件夹！", 0, 0)
   
10. 
    
11.     SearchPath = objFolder.self.Path & ""
    
12. 
    
13.     Set objShell = Nothing
    
14.     Set objFolder = Nothing
    
15. 
    
16.     If MsgBox("请确认！是否处理文件夹 " & SearchPath & " ?", 4 + 16) = vbNo Then Exit Sub
    
17. 
    
18.     Set DicList = CreateObject("Scripting.Dictionary")
    
19.     Set FileList = CreateObject("Scripting.Dictionary")
    
20. 
    
21.     DicList.Add SearchPath, ""
    
22. 
    
23.     i = 0
    
24.     Do While i < DicList.Count
    
25.         Key = DicList.keys
    
26.         NowDic = Dir(Key(i), vbDirectory)
    
27.         Do While NowDic <> ""
    
28.             If (NowDic <> ".") And (NowDic <> "..") Then
    
29.                 If (GetAttr(Key(i) & NowDic) And vbDirectory) = vbDirectory Then DicList.Add Key(i) & NowDic & "", ""
    
30.             End If
    
31.             NowDic = Dir()
    
32.         Loop
    
33.         i = i + 1
    
34.     Loop
    
35. 
    
36.     For Each Key In DicList.keys
    
37.         NowFile = Dir(Key)
    
38.         Do While NowFile <> ""
    
39.             FileList.Add NowFile, Key
    
40.             NowFile = Dir()
    
41.         Loop
    
42.     Next
    
43. 
    
44.     i = 0
    
45.     FileName = FileList.keys
    
46.     FilePath = FileList.Items
    
47.     Do While i < FileList.Count
    
48.         If FilePath(i) & FileName(i) Like "*.doc*" Then
    
49.             Set doc = Documents.Open(FileName:=FilePath(i) & FileName(i), Visible:=True)
    
50. '
    
51.             With doc
    
52.                 If .Paragraphs.Count >= 5 Then
    
53.                 Set r = .Range(Start:=.Paragraphs(2).Range.Start, End:=.Paragraphs(5).Range.End)
    
54.                     For j = 0 To UBound(arr)
    
55.                         For Each a In r.Paragraphs
    
56.                             If Len(r) = 0 Then Exit For
    
57.                             With a.Range
    
58.                                 If Not .Information(12) Then
    
59.                                     If .Text Like "*" & arr(j) & "*" Then .Delete
    
60.                                 End If
    
61.                             End With
    
62.                         Next
    
63.                     Next j
    
64.                 End If
    
65.             End With
    
66. '
    
67.             doc.Close SaveChanges:=wdSaveChanges
    
68.             x = x + 1
    
69.         End If
    
70.         i = i + 1
    
71.     Loop
    
72. 
    
73.     Set DicList = Nothing
    
74.     Set FileList = Nothing
    
75. 
    
76.     MsgBox "文件夹包含 " & i & " 个文件！" & vbCr & "共处理 Word 文档(*.docx/*.doc) " & x & " 个！", 0 + 48
    
77. End Sub

复制代码