如何通过代码将关键字所在的段落提取到新文档中？

tangqingfu

duquancai 发表于 2019-5-16 00:27

谢谢duquancai兄的代码，测试效果很理想！又见字典

tangqingfu

duquancai 发表于 2019-5-16 00:27

能否请duquancai兄修改下代码，对关键字字体进行限定，并做”全字匹配",保证查找的准确性：
只查找音标字体（如arial字体），其它字体（如单词字体“Time New Romans)不做查找
如在查找音标I时，不查找音标aI

duquancai

tangqingfu 发表于 2019-5-16 09:34
能否请duquancai兄修改下代码，对关键字字体进行限定，并做”全字匹配",保证查找的准确性：
只查找音标 ...

有具体需求，自己修改吧！你也是论坛的大神了！

tangqingfu

duquancai 发表于 2019-5-16 12:29
有具体需求，自己修改吧！你也是论坛的大神了！

VBA我是小白，感谢杜兄的多次指点！

tangqingfu

duquancai 发表于 2019-5-16 00:27

20楼代码在提取到新文档时无法做到保持原有格式（颜色），请教杜老师，如何修改代码做到提取后保留原有格式（如字体，颜色等）

tangqingfu

以下是杜老师帮写的代码（将关键字所在的段落提取到新文档中），可惜无法做到保持原有格式（颜色），请教如何修改代码做到提取后保留原有格式（如字体，颜色等）？

1. Sub main()
   
2.     Dim doc As Document, re As Object, mh As Object
   
3.     Dim mystr$, keystr$, restr$, results$, i&, n&
   
4.     If Selection.Type = wdSelectionIP Then
   
5.         MsgBox "没选择关键字！": Exit Sub
   
6.     Else
   
7.         keystr = Selection.Text '选择文档中某一处“关键字”
   
8.     End If
   
9.     For i = 1 To Len(keystr)
   
10.         restr = restr & "\u" & Right("0000" & Hex$(AscW(Mid(keystr, i, 1))), 4)
    
11.     Next
    
12.     Set doc = ActiveDocument
    
13.     mystr = doc.Content.Text
    
14.     Set re = CreateObject("vbscript.regexp")
    
15.     re.Global = True: re.Pattern = restr
    
16.     Dim d As Object
    
17.     Set d = CreateObject("Scripting.Dictionary")
    
18.     For Each mh In re.Execute(mystr)
    
19.         i = mh.FirstIndex: n = mh.Length
    
20.         With doc.Range(i, i + n)
    
21.             .Expand 4
    
22.             d(.Text) = vbNullString
    
23.         End With
    
24.     Next
    
25.     For Each k In d.keys
    
26.         results = results & k
    
27.     Next
    
28.     With Documents.Add
    
29.         .Content.InsertAfter results
    
30.     End With
    
31. End Sub

复制代码

mmcha2002

zhanglei1371 发表于 2019-5-11 22:57
问题过于简单，严重缺乏挑战性！难度增加三倍，就有代码了:)^-^

请问一下，能不能帮忙处理一下这个代码？