遍历所有Word文档，查找指定关键字，找到后整段复制到新的文档中，有几段就复制几段

nsxlyj

遍历当前Word文件所在文件下的每一个Word文档，按指定关键字查找，将关键字所在的段落整段依次复制到新的文档，一个文档查找完接着查找第2个文档，直到找完所有文档。比如查找“人类”，在第一个文档的第3段找到关键字，就把这一段复制到一个新建的Word文档中（命名为：关于“人类”的素材），如果又在第8段次找到“人类”这两个字，将第8段复制到《关于“人类”的素材》中，放在上次复制内容的后方（另起一段）。不断重复前面的步骤，直到所有段落找完，接着查找第2个文档，直到找完所有文档。所有查找过的Word文件都不用打开。

以下是自己写的，只能完成一个文档内所有段落的遍历。VBA还未入门，解决不了这个难题，请哪位坛友帮忙指导一下，谢谢！

Sub 找到《关键字》就整段复制到新文档末尾()

Dim i, n, k, myrange

k = ActiveDocument.Paragraphs.Count

For Each i In ActiveDocument.Paragraphs

n = n + 1

If n > k Then Exit Sub

If InStr(i, "人类") <> 0 Then

Set myrange =ActiveDocument.Range(Start:=ActiveDocument.Paragraphs(n).Range.Start,End:=ActiveDocument.Paragraphs(n).Range.End)

myrange.Select

Selection.Copy

Selection.EndKey Unit:=wdStory

Selection.TypeParagraph

Selection.PasteAndFormat (wdPasteDefault)

End If

Next

End Sub

模拟的文档分别是《神态》《2019》《文档1》，实际工作中文档数量不确定，最多时会达到100多个。

处理后要达到的效果见《关于“人类”的素材》

约定的童话

你这是Word宏吧？MARK学习一下

ggmmlol

1. Sub test()
   
2.     Dim mypath$, f$, n&, tmp$
   
3.     Dim par As Paragraph, doc As Document
   
4.     mypath = ThisDocument.Path & ""
   
5.     f = Dir(mypath & "*.docx")
   
6.     Dim ret$()
   
7.     Do While Len(f)
   
8.         If f <> "关于“人类”的素材.docx" Then
   
9.             Set doc = Documents.Open(mypath & f)
   
10.             For Each par In doc.Paragraphs
    
11.                 tmp = par.Range.Text
    
12.                 If InStr(tmp, "人类") > 0 Then
    
13.                     n = n + 1
    
14.                     ReDim Preserve ret(1 To n)
    
15.                     ret(n) = tmp
    
16.                 End If
    
17.             Next
    
18.             doc.Close
    
19.         End If
    
20.         f = Dir
    
21.     Loop
    
22.     If n = 0 Then Exit Sub
    
23.     f = mypath & "关于“人类”的素材.docx"
    
24.     If Len(Dir(f)) Then Kill f
    
25.     Set doc = Documents.Add
    
26.     doc.Range.Text = Join(ret, "")
    
27.     doc.SaveAs f
    
28.     doc.Close
    
29.     Set doc = Nothing
    
30. End Sub

复制代码

nsxlyj

ggmmlol 发表于 2020-9-22 20:02

谢谢你的帮助！

ggmmlol

第4行代码应该是下面这样的：
mypath = ThisDocument.Path & "\"

因为代码框存在Bug，反斜杠被它“吃”掉了。

nsxlyj

ggmmlol 发表于 2020-9-22 20:02

太强大了，解决了我找素材的大难题，再次感谢！

nsxlyj

ggmmlol 发表于 2020-9-22 20:02

老师，上次在你的帮助下，解决了查找资料的难题，现在希望将资料中重复的段落只保留一段，其余的删除。有没有时间帮我看一下。谢谢！
http://club.excelhome.net/forum. ... ;extra=#pid10481801