如何给制定的几个单词标注红色下划线

zzpsx

如何给制定的几个单词标注红色下划线.rar (11.96 KB, 下载次数: 12)

2020-8-11 07:23 上传

点击文件名下载附件

如何写一段代码,执行以后,可以搜索文中是否有以下单词：but,something,anything,nothing,everything

如果有,则全部标红加下划线，不用考虑大小写和重复出现。

以下为试验文本：

Couple restores antique sewing machine to make face masks

After sitting idle for several decades, a nearly 100-year-old sewingmachine has been put to good use during the Covid-19 pandemic.

"We dug it out, dusted it off, and oiled the entiremachine," he said.

Giselle Williams had never sewn anythingbefore her mask-making endeavors but learned quickly under her husband's expertinstruction. His grandmother, Lovetta Corbell, was a seamstress and taught himto sew in the summers he spent with her during his childhood. He showed hiswife how to thread the machine, wind a bobbin, and sew a straight stitch.

"In my wildest dreams, I would have never guessed that the timemy grandmother spent with me on her Singer would come back to bear fruit ...responding to a real need," he said.

Before long, they were supplying friends, family, and frontlineworkers with masks. Their team efforts inspired other members of theircommunity to get involved. Family, friends and neighbors donated fabric tosupport the couple's mission.

小花鹿

Sub xiaohualu()
Dim s, ar, i&
s = "but,something,anything,nothing,everything"
ar = Split(s, ",")
For i = 0 To UBound(ar)
    With ThisDocument.Content.Find
        Do While .Execute(ar(i))
            .Parent.Font.Color = wdColorRed
        Loop
    End With
Next i
End Sub

zzpsx

小花鹿 发表于 2020-8-11 08:47
Sub xiaohualu()
Dim s, ar, i&
s = "but,something,anything,nothing,everything"

用我的附件执行这个代码，好像没反应，不知道我的问题出在哪里。

cuanju

Sub dm1()
    Dim arr, i&
    arr = Array("but", "something", "anything", "nothing", "everything")
    For i = 0 To UBound(arr)
        With ActiveDocument.Content.Find
            .ClearFormatting
            .MatchWildcards = True
            .Text = arr(i)
            With .Replacement
                .ClearFormatting
                .Font.Color = vbRed
                .Font.Underline = wdUnderlineSingle
            End With
            .Execute Format:=True, Replace:=wdReplaceAll
        End With
    Next i
End Sub

daibao88

zzpsx 发表于 2020-8-11 08:59
用我的附件执行这个代码，好像没反应，不知道我的问题出在哪里。

Sub xiaohualu()
Dim s, ar, i&
s = "but,something,anything,nothing,everything"
ar = Split(s, ",")
For i = 0 To UBound(ar)
    With ThisDocument.Content.Find
        Do While .Execute(ar(i))
            .Parent.Font.Color = wdColorRed
            .Parent.Font.Underline = wdUnderlineSingle
        Loop
    End With
Next i
End Sub、代码没问题

zzpsx

cuanju 发表于 2020-8-11 09:09
Sub dm1()
    Dim arr, i&
    arr = Array("but", "something", "anything", "nothing", "everything ...

能全字匹配就更好了。
还有，如果能把任何以ly结尾的单词也标注红色下划线，就更好了。

cuanju

zzpsx 发表于 2020-8-11 09:14
能全字匹配就更好了。
还有，如果能把任何以ly结尾的单词也标注红色下划线，就更好了。

Sub dm5()
Rem 全字匹配，例如匹配but时不会匹配distribute和contribution
    Dim arr, i&
    arr = Array("but", "something", "anything", "nothing", "everything")
    For i = 0 To UBound(arr)
        With ActiveDocument.Content.Find
            .ClearFormatting
            .MatchWholeWord = True '全字匹配
            .MatchWildcards = False '不使用通配符
            .Text = arr(i)
            With .Replacement
                .ClearFormatting
                .Font.Color = vbRed
                .Font.Underline = wdUnderlineSingle
            End With
            .Execute Format:=True, Replace:=wdReplaceAll
        End With
    Next i
End Sub

cuanju

Sub f6()
    Rem ly结尾的单词标注红色下划线（但注意会出现：family也会标红色下划线问题，后期用代码做删除处理）
    With ActiveDocument.Content.Find
        .ClearFormatting
        .MatchWildcards = True '使用通配符
        .Text = "[A-Za-z]@ly>"
        With .Replacement
            .ClearFormatting
            .Font.Color = vbRed
            .Font.Underline = wdUnderlineSingle
        End With
        .Execute Format:=True, Replace:=wdReplaceAll
    End With

    '以下代码处理family（不区分大小写）
    With ActiveDocument.Content.Find
        .ClearFormatting
        .Text = "family"
        With .Replacement
            .ClearFormatting
            .Font.Color = vbBlack
            .Font.Underline = wdUnderlineNone
        End With
        .Execute Format:=True, Replace:=wdReplaceAll
    End With
End Sub

413191246se

1. Sub aaaa单词标红加下划线()
   
2. 'code by xiaohualu
   
3.     Dim s$, arr, i&
   
4.     s = "but,something,anything,nothing,everything"
   
5.     arr = Split(s, ",")
   
6.     For i = 0 To UBound(arr)
   
7.         With ActiveDocument.Content.Find
   
8.             .ClearFormatting
   
9.             .Text = arr(i)
   
10.             .Forward = True
    
11.             .MatchWildcards = False
    
12.             .MatchWholeWord = True
    
13.             Do While .Execute
    
14.                 With .Parent
    
15.                     .Font.Color = wdColorRed
    
16.                     .Underline = wdUnderlineSingle
    
17.                 End With
    
18.             Loop
    
19.         End With
    
20.     Next
    
21. 'code by cuanju
    
22.     With ActiveDocument.Content.Find
    
23.         .ClearFormatting
    
24.         .Text = "[A-Za-z]@ly>"
    
25.         .Forward = True
    
26.         .MatchWildcards = True
    
27.         Do While .Execute
    
28.             With .Parent
    
29.                 .Font.Color = wdColorPink
    
30.                 .Underline = wdUnderlineSingle
    
31.             End With
    
32.         Loop
    
33.     End With
    
34. End Sub

复制代码

413191246se

* 楼上代码，成功算 小花鹿老师/cuanju老师的功劳，不成功算我的。
* 第二段，我查找“<[^32]@ly>”，结果，形成无限循环，后来，我用 字长=0 终止程序，不如 cuanju 老师的好。