Word VBA如何把当前文档里红色的字添加下划线？

文字太多，遍历很费时间吧。如果用查找替换功能，请问宏代码如何实现呢？

Sub UnderlineRedText()
    For Each w In ActiveDocument.Words
        ' 判断字体颜色是否为红色
        If w.Font.Color = wdColorRed Then
            ' 添加下划线
            w.Font.Underline = wdUnderlineSingle
        End If
    Next w
End Sub