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

o0star0o

RT，把所有word全文不是红色的字体，都改成黑色，求这个宏

413191246se

1. Sub test非红色字符转黑色()
   
2.     With ActiveDocument
   
3.         '红色字符加下划线
   
4.         With .Content.Find
   
5.             .ClearFormatting
   
6.             .Font.Color = wdColorRed
   
7.             With .Replacement
   
8.                 .ClearFormatting
   
9.                 .Font.Underline = wdUnderlineSingle
   
10.             End With
    
11.             .Execute FindText:="", ReplaceWith:="", Format:=True, Replace:=wdReplaceAll
    
12.         End With
    
13. 
    
14.         '全文设为黑色
    
15.         .Content.Font.Color = wdColorBlack
    
16. 
    
17.         '查找下划线字符设为红色，并取消下划线
    
18.          With .Content.Find
    
19.             .ClearFormatting
    
20.             .Font.Underline = wdUnderlineSingle
    
21.             With .Replacement
    
22.                 .ClearFormatting
    
23.                 With .Font
    
24.                     .Color = wdColorRed
    
25.                     .Underline = wdUnderlineNone
    
26.                 End With
    
27.             End With
    
28.             .Execute FindText:="", ReplaceWith:="", Format:=True, Replace:=wdReplaceAll
    
29.         End With
    
30.     End With
    
31. End Sub

复制代码

liuhoubin168

楼上，方法不错！

413191246se

谢谢楼上朋友！ 我很想一步就完成，比如如果能有 .Font.Color = unwdColorRed 这样的语句，但 .Color 是属性，不是方法，恐怕就不能实现了。还好，全文替换速度很快（代码是照抄微软VBA帮助的）。

相见是缘8

413191246se 发表于 2019-6-7 01:01
谢谢楼上朋友！ 我很想一步就完成，比如如果能有 .Font.Color = unwdColorRed 这样的语句，但 .Color 是属 ...

这个一步就完成，可能较难！除非可对未选定部分替换。

daibao88

迂回战术不错

413191246se

刚才编了一个小宏，逐字符判断，结果实测需等待很久，等了一会儿，我给中断了。2楼代码反复替换，用时很短，实测是 .23 秒，确实极快。测试文本有 3200 字。

daibao88

Sub test()
    Dim myrange As Range, start As Long, endl As Long
    endl = ActiveDocument.Range.End
    Set myrange = ActiveDocument.Range
    Do
        With myrange.Find
            .ClearFormatting
            .Font.ColorIndex = wdRed
            .Execute
            If .Found = False Then Exit Do
            ActiveDocument.Range(start, myrange.start).Font.ColorIndex = wdBlack
            start = myrange.End
            Set myrange = ActiveDocument.Range(start, endl)
        End With
    Loop
    ActiveDocument.Range(start, endl).Font.ColorIndex = wdBlack
End Sub

小花鹿

Sub xiaohualu()
    Dim st As Long, ed As Long, AD As Document
    Set AD = ActiveDocument
    With AD.Content.Find
        .ClearFormatting
        .Font.ColorIndex = wdRed
        Do While .Execute
            ed = .Parent.start
            AD.Range(st, ed).Font.ColorIndex = wdBlack
            st = .Parent.End
        Loop
    End With
    ed = AD.Range.End
    AD.Range(st, ed).Font.ColorIndex = wdBlack
End Sub

413191246se

* 测试结果（测试文档 3200字）：
* 413191246se 代码，用时 0.21 秒
* daibao88朋友代码，用时 6.20 秒
* 小花鹿 老师  代码，用时 6.68 秒
* 总结：本题不能用常规 VBA 编程，须用查找替换最快（我的代码是照抄微软官方 VBA 帮助的）。