word中查找每行中的重复字并标注，vba怎么实现？

gsljz

希望能够搜索每一行（或者说是每一个段落中），括号前面的文字和括号后面的文字是否有相同的字。

只做括号前后比较，如果括号前面有重字，或者括号后面有重字，都不标注。括号内的内容不参与搜索。

请问在word里面可否通过VBA的方法实现。
详见附件。
谢谢！

413191246se

楼主，我下载后提示文件已损坏，请重新上传附件吧！

gsljz

To 413191246se：  文件下载可以打开呢，可能您没有下完整呢。我把word里面的内容贴在下面给您看一下吧。谢谢。

1、        不敢全抛一片心（航海名词）安全通信
2、        木兰之子（植物）花生

以上内容有几十行，或者几百行。希望能够搜索每一行（或者说是每一个段落中），括号前面的文字和括号后面的文字是否有相同的字。
例如第一行中的“全”字，如果发现相同字，需要把前后的“全”字标为红色。
只做括号前后比较，如果括号前面有重字，或者括号后面有重字，都不标注。括号内的内容不参与搜索。（可以把括号内的内容先标上颜色，使其不参与搜索？）
请问在word里面可否通过VBA的方法实现。
http://club.excelhome.net/thread-773153-1-1.html 帖子里的方法，不能很好完成功能。希望改进并提供更好功能。谢谢！

ming0018

看一下，这样是不是你要的效果？

gsljz

to：ming0018：是的是的，请老师请帮忙，谢谢！

ming0018

gsljz 发表于 2018-10-31 12:23
to：ming0018：是的是的，请老师请帮忙，谢谢！

1. Sub test()
   
2.     Dim doc As Document, Str$, Str_Combine$, i%, Str_Left$, Str_Right$, Str_LeftNum%, Str_RightNum%
   
3.     Dim dic As Object, Par As Paragraph
   
4.     Set doc = ActiveDocument: Set dic = CreateObject("scripting.dictionary") '定义词典
   
5.     For Each Par In doc.Paragraphs
   
6.         Str = Replace(Par.Range.Text, vbCr, "")
   
7.         Str_LeftNum = InStr(Str, "（")
   
8.         Str_RightNum = InStrRev(Str, "）")
   
9.         If Str_LeftNum > 1 And Str_RightNum Then
   
10.             Str_Left = left(Str, Str_LeftNum - 1)
    
11.             Str_Right = Right(Str, Len(Str) - Str_RightNum)
    
12.             Str_Combine = Str_Left & Str_Right
    
13.             For i = 1 To Len(Str_Combine)
    
14.                 If dic.Exists(Mid(Str_Combine, i, 1)) Then
    
15.                     If i >= Str_LeftNum Then
    
16.                         Call findstr(Par.Range, Mid(Str_Combine, i, 1))
    
17.                     End If
    
18.                 Else
    
19.                     dic(Mid(Str_Combine, i, 1)) = ""
    
20.                 End If
    
21.             Next i
    
22.             dic.RemoveAll
    
23.         Else
    
24.             msgbox "第" & doc.Range(0, Par.Range.End).Paragraphs.Count & "段,段落不标准"
    
25.             End
    
26.         End If
    
27.     Next
    
28. End Sub
    
29. 
    
30. Sub findstr(myRng As Range, findtext As String)
    
31.     Dim doc As Document: Set doc = ActiveDocument
    
32.     With myRng.Find
    
33.         .Text = findtext
    
34.         .Replacement.Font.ColorIndex = wdRed
    
35.         .Execute Replace:=wdReplaceAll
    
36.     End With
    
37. End Sub

复制代码

gsljz

下载试了一下，很好用。感谢ming0018老师的帮助！

gsljz

挺好的。谢谢！