求一个word宏，把非红色的字体都换成黑色

小花鹿

413191246se 发表于 2019-6-7 20:31
* 测试结果（测试文档 3200字）：
* 413191246se 代码，用时 0.21 秒
* daibao88朋友代码，用时 6.20 秒
...

我这里9万字，我的代码2秒，你的代码0.5秒，是4倍，而你那里是30倍，不知道为什么会有这么大的差距

daibao88

413191246se 发表于 2019-6-7 20:31
* 测试结果（测试文档 3200字）：
* 413191246se 代码，用时 0.21 秒
* daibao88朋友代码，用时 6.20 秒
...

是的，小花鹿老师及我的代码确实存在多次循环，时间长的问题。但你的代码有点取巧，原文必须没有使用字符下划线。

413191246se

小花鹿 老师“9万字 2秒”，我信！daibao88朋友说“必须没有下划线”确实如此，我是取巧了，有漏洞，不算真功夫，你们才是真功夫！谢谢 两位！

相见是缘8

413191246se 发表于 2019-6-7 23:43
小花鹿 老师“9万字 2秒”，我信！daibao88朋友说“必须没有下划线”确实如此，我是取巧了，有漏洞，不算真 ...

漏洞可根据原文上：不同的字体、字体的大小、颜色、字形…等，修改代码避开。

duquancai

1. Type node
   
2.     mystar As Long
   
3.     myend As Long
   
4. End Type
   
5. Dim arr() As node
   
6. Sub main()
   
7.     Dim doc As Document
   
8.     Set doc = ActiveDocument
   
9.     If Not get_data(doc) Then Exit Sub
   
10.     For i = 0 To UBound(arr)
    
11.         doc.Range(arr(i).mystar, arr(i).myend).Font.ColorIndex = wdRed
    
12.     Next
    
13. End Sub
    
14. Function get_data(ByRef doc As Document) As Boolean
    
15.     Dim n As Long
    
16.     With doc.Content.Find
    
17.         .Font.ColorIndex = wdRed
    
18.         Do While .Execute
    
19.             ReDim Preserve arr(n)
    
20.             arr(n).mystar = .Parent.Start
    
21.             arr(n).myend = .Parent.End
    
22.             n = n + 1
    
23.         Loop
    
24.     End With
    
25.     If n > 0 Then get_data = True Else Exit Function
    
26.     doc.Content.Font.ColorIndex = wdBlack
    
27. End Function

复制代码

duquancai

如果说楼上代码理解有难度，那么请看下面的代码（应该好理解了！）

1. Sub main()
   
2.     Dim doc As Document, i As Long, arr()
   
3.     Set doc = ActiveDocument
   
4.     If Not get_data(doc, arr) Then Exit Sub
   
5.     For i = 1 To UBound(arr, 2)
   
6.         doc.Range(arr(1, i), arr(2, i)).Font.ColorIndex = wdRed
   
7.     Next
   
8. End Sub
   
9. Function get_data(ByRef doc As Document, ByRef arr) As Boolean
   
10.     Dim n As Long
    
11.     With doc.Content.Find
    
12.         .Font.ColorIndex = wdRed
    
13.         Do While .Execute
    
14.             n = n + 1
    
15.             ReDim Preserve arr(1 To 2, 1 To n)
    
16.             arr(1, n) = .Parent.Start
    
17.             arr(2, n) = .Parent.End
    
18.         Loop
    
19.     End With
    
20.     If n > 0 Then get_data = True Else Exit Function
    
21.     doc.Content.Font.ColorIndex = wdBlack
    
22. End Function

复制代码

小花鹿

duquancai 发表于 2019-6-8 19:27
如果说楼上代码理解有难度，那么请看下面的代码（应该好理解了！）

学习一下                                                                                                                  

duquancai

小花鹿 发表于 2019-6-8 22:28
学习一下                                                                                           ...

再看看以下代码》》》》

1. Sub main()
   
2.     Dim doc As Document, r As Variant, arr() As Range
   
3.     Set doc = ActiveDocument
   
4.     If Not get_data(doc, arr()) Then Exit Sub
   
5.     For Each r In arr
   
6.         r.Font.ColorIndex = wdRed
   
7.     Next
   
8. End Sub
   
9. Function get_data(ByRef doc As Document, ByRef arr() As Range) As Boolean
   
10.     Dim n As Long
    
11.     With doc.Content.Find
    
12.         .Font.ColorIndex = wdRed
    
13.         Do While .Execute
    
14.             n = n + 1: ReDim Preserve arr(1 To n)
    
15.             Set arr(n) = .Parent.Duplicate
    
16.         Loop
    
17.     End With
    
18.     If n > 0 Then get_data = True Else Exit Function
    
19.     doc.Content.Font.ColorIndex = wdBlack
    
20. End Function

复制代码

小花鹿

duquancai 发表于 2019-6-9 21:13
再看看以下代码》》》》

这个好，第二次见Duplicate了

侠之大者为Excel

413191246se 发表于 2019-6-6 03:06

厉害厉害啊。。。。。