求助：word批量查找重复的字或词

tanshuizhu

求助各位大佬，可否VB实现word批量查找重复的字或词，如公司公司、的的、；；、。。、等等，具体见附件

413191246se

(?)\1
(??)\1
勾选“使用通配符”

413191246se

楼主，下面代码可自动删除所有重复的字、词（红色显示）：

1. Sub aaaa_删除重复字词()
   
2.     With ActiveDocument.Content.Find
   
3.         .ClearFormatting
   
4.         .Text = "(?)\1"
   
5.         .Forward = True
   
6.         .MatchWildcards = True
   
7.         Do While .Execute
   
8.             With .Parent
   
9.                 .Font.Color = wdColorRed '红色（此行代码可删除！）
   
10.                 With .Characters.Last
    
11.                     If .Text Like "[一-﨩]" Then .Delete
    
12.                 End With
    
13.                 .Start = .End
    
14.             End With
    
15.         Loop
    
16.     End With
    
17.     With ActiveDocument.Content.Find
    
18.         .ClearFormatting
    
19.         .Text = "(??)\1"
    
20.         .Forward = True
    
21.         .MatchWildcards = True
    
22.         Do While .Execute
    
23.             With .Parent
    
24.                 .Font.Color = wdColorRed '红色（此行代码可删除！）
    
25.                 With .Characters.Last
    
26.                     If .Text Like "[一-﨩]" Then .Delete
    
27.                 End With
    
28.                 With .Characters.Last
    
29.                     If .Text Like "[一-﨩]" Then .Delete
    
30.                 End With
    
31.                 .Start = .End
    
32.             End With
    
33.         Loop
    
34.     End With
    
35.     MsgBox "OK!", 0 + 48
    
36. End Sub

复制代码

tanshuizhu

413191246se 发表于 2021-10-29 19:46
楼主，下面代码可自动删除所有重复的字、词（红色显示）：

可否实现只显示不删除呢，谢谢

tanshuizhu

413191246se 发表于 2021-10-29 16:50
(?)\1
(??)\1
勾选“使用通配符”

好的，我试试，谢谢

tanshuizhu

413191246se 发表于 2021-10-29 19:46
楼主，下面代码可自动删除所有重复的字、词（红色显示）：

非常感谢，您代码可以运行，但可否不对数字进行检索？数字有重复很多的

一帆风顺2020

1. Sub test()
   
2.     Dim st$
   
3.     Dim ph
   
4.     Dim doc As Document
   
5.     ph = ThisDocument.Path & ""
   
6.     st = Dir(ph & "*.doc*")
   
7.     Do While st <> ""
   
8.         If st <> ThisDocument.Name Then
   
9.             Set doc = Documents.Open(ph & st)
   
10.             fx doc
    
11.             doc.Close (True)
    
12.             Set doc = Nothing
    
13.         End If
    
14.         st = Dir()
    
15.     Loop
    
16.     MsgBox "OK!", 0 + 48
    
17. End Sub
    
18. Function fx(doc As Document)
    
19.     Dim x%
    
20.     doc.Activate
    
21.     '.ClearFormatting
    
22.     With ActiveDocument.Content.Find
    
23. 
    
24.         .Text = "([!^13^11(0-9)]@)\1"
    
25.         .Forward = True
    
26.         .MatchWildcards = True
    
27.         Do While .Execute
    
28.             With .Parent
    
29.                 .Font.Color = wdColorRed
    
30.                 .Start = .End
    
31.             End With
    
32.         Loop
    
33. 
    
34.     End With
    
35. End Function

复制代码

413191246se

楼主，请测试：

1. Sub aaaa查找重复字词()
   
2.     ActiveDocument.Content.Font.ColorIndex = wdAuto
   
3.     With ActiveDocument.Content.Find
   
4.         .ClearFormatting
   
5.         .Text = "([一-﨩])\1"
   
6.         .Forward = True
   
7.         .MatchWildcards = True
   
8.         Do While .Execute
   
9.             .Parent.Font.Color = wdColorRed
   
10.         Loop
    
11.     End With
    
12.     With ActiveDocument.Content.Find
    
13.         .ClearFormatting
    
14.         .Text = "([一-﨩][一-﨩])\1"
    
15.         .Forward = True
    
16.         .MatchWildcards = True
    
17.         Do While .Execute
    
18.             .Parent.Font.Color = wdColorPink
    
19.         Loop
    
20.     End With
    
21.     MsgBox "OK!", 0 + 48
    
22. End Sub

复制代码