求优化！将文章中第二次以后出现的字，随机换一种指定字体

liuhong2087

效果：将文章中第二次以后出现的字，随机换一种指定字体
问题：我写了一个代码，但是循环次数太多，少量文字还可以，遇到大量文字，代码就跑不动了
请教大神有没有更简单的方法实现此效果

413191246se

楼主，你好厉害呀！新人就会函数，我8年的老人了，一点儿也不会函数。我也写了一个VBA小宏，算法很简单，循环遍历所有字符，跳过有下划线字符，四种空格，速度也有点儿慢，但是能够完成功能。不满意可以弃用：

1. Sub test()
   
2.     Dim n&, m&, s$, i&
   
3.     With ActiveDocument
   
4.         m = .Characters.Count
   
5.         For n = 1 To m
   
6.             i = 0
   
7.             s = .Characters(n).Text
   
8.             If .Characters(n).Underline = wdUnderlineSingle Then GoTo sk
   
9.             If .Characters(n).Text = vbCr Then GoTo sk
   
10.             If .Characters(n).Text = " " Then GoTo sk
    
11.             If .Characters(n).Text = "　" Then GoTo sk
    
12.             If .Characters(n).Text = ChrW(160) Then GoTo sk
    
13.             If .Characters(n).Text = vbTab Then GoTo sk
    
14.             With .Content.Find
    
15.                 .ClearFormatting
    
16.                 .Text = s
    
17.                 .Forward = True
    
18.                 .MatchWildcards = True
    
19.                 Do While .Execute
    
20.                     With .Parent
    
21.                         i = i + 1
    
22.                         .Select
    
23.                         .Underline = wdUnderlineSingle
    
24.                         If i = 5 Then i = 1
    
25.                         If i = 1 Then
    
26.                             .Font.Name = "宋体"
    
27.                         ElseIf i = 2 Then
    
28.                             .Font.Name = "仿宋"
    
29.                         ElseIf i = 3 Then
    
30.                             .Font.Name = "楷体"
    
31.                         ElseIf i = 4 Then
    
32.                             .Font.Name = "黑体"
    
33.                         End If
    
34.                     End With
    
35.                 Loop
    
36.             End With
    
37. sk:
    
38.         Next n
    
39.         .Content.Underline = wdUnderlineNone
    
40.     End With
    
41.     Selection.HomeKey 6
    
42. End Sub

复制代码

ming0018

413191246se 发表于 2019-5-16 15:23
楼主，你好厉害呀！新人就会函数，我8年的老人了，一点儿也不会函数。我也写了一个VBA小宏，算法很简单，循 ...

继续优化
继续优化
继续优化

huanglicheng

最快的方法 一秒钟左右

1. Sub test()
   
2.     Dim mText As String
   
3.     Dim newText$
   
4.     Dim dic As Object
   
5.     Set dic = CreateObject("scripting.dictionary")
   
6.     t = Timer
   
7.     Application.ScreenUpdating = False
   
8.     With ActiveDocument
   
9.         newText = .Content.Text
   
10.         For i = 1 To Len(newText)
    
11.             mText = Mid(newText, i, 1)
    
12.             If mText Like "[一-﨩]" Then
    
13.                 If dic.Exists(mText) = False Then
    
14.                     dic(mText) = 0
    
15.                 Else
    
16.                     .Range(i - 1, i).Font.ColorIndex = wdBlue
    
17.                 End If
    
18.             End If
    
19.         Next i
    
20.     End With
    
21.     Application.ScreenUpdating = True
    
22.     MsgBox Timer - t
    
23. End Sub
    

复制代码

413191246se

谢谢 ming 老师，我已尽力了，无法再优化。

liuhong2087

413191246se 发表于 2019-5-16 15:23
楼主，你好厉害呀！新人就会函数，我8年的老人了，一点儿也不会函数。我也写了一个VBA小宏，算法很简单，循 ...

大哥，您抬举小弟了，这个代码我都写了好久。您这代码够我研究几天了，超级感谢

liuhong2087

huanglicheng 发表于 2019-5-16 17:08
最快的方法 一秒钟左右

这个太强大了，跪谢

liuhong2087

huanglicheng 发表于 2019-5-16 17:08
最快的方法 一秒钟左右

大哥，如果只在选区内运行，是否可行

huanglicheng

liuhong2087 发表于 2019-5-17 12:11
大哥，如果只在选区内运行，是否可行

供参考

1. Sub test()
   
2.     Dim mText As String
   
3.     Dim newText$, mStart As Long
   
4.     Dim dic As Object
   
5.     Set dic = CreateObject("scripting.dictionary")
   
6.     t = Timer
   
7.     Application.ScreenUpdating = False
   
8.    
   
9.     newText = Selection.Range.Text
   
10.     mStart = Selection.Range.Start
    
11.     With ActiveDocument
    
12.         For i = 1 To Len(newText)
    
13.             mText = Mid(newText, i, 1)
    
14.             If mText Like "[一-﨩]" Then
    
15.                 If dic.Exists(mText) = False Then
    
16.                     dic(mText) = 0
    
17.                 Else
    
18.                     .Range(mStart + i - 1, mStart + i).Font.ColorIndex = wdBlue
    
19.                 End If
    
20.             End If
    
21.         Next i
    
22.     End With
    
23.     Application.ScreenUpdating = True
    
24.     MsgBox Timer - t
    
25. End Sub
    
26. 
    

复制代码

liuhong2087

huanglicheng 发表于 2019-5-17 14:08
供参考

可能对于大佬来说，这个简单的代码不值一提，但对新手来说，一个指点，都够学习好几天了，再次摩拜