替换字符格式

2567408563

请教大神们，如何批量替换字符格式
数据结果模拟如图所示，把单词里把包含的字母替换成红色并加上下划线！
PS 附件只是部分的数据，实际数据量会很多！

MOY838840554

Sub 替换()
    Dim rng As Range, tr&, s, sLen%, sStart%, ts$
    Set rng = Range("A1").CurrentRegion
    tr = 2 '条件在第2行
    Set rng = rng.Offset(tr, 1) '要处理的行下偏到tr条件行，偏1列，避开A列
    For Each s In rng
        If s = "" Then GoTo 100:
        ts = Cells(tr, s.Column).Value
        sLen = Len(ts)
        sStart = InStr(s, ts)
        With s.Characters(Start:=sStart, Length:=sLen).Font
            .Underline = xlUnderlineStyleSingle
            .Color = -16776961
        End With
100:
    Next
End Sub

dsmch

1. Sub dsmch()
   
2. arr = Range("a1").CurrentRegion
   
3. For j = 2 To UBound(arr, 2)
   
4.     zf = Cells(2, j)
   
5.     For i = 3 To UBound(arr)
   
6.         If arr(i, j) <> "" Then
   
7.             With Cells(i, j).Characters(Start:=InStr(Cells(i, j), zf), Length:=Len(zf)).Font
   
8.                 .Underline = xlUnderlineStyleSingle
   
9.                 .Color = RGB(255, 0, 0)
   
10.             End With
    
11.         End If
    
12.     Next
    
13. Next
    
14. End Sub

复制代码

liujialin0o0

不区分大小写,没有找到的单元格标黄色底纹

1. Sub test()
   
2. m = Cells(2, Columns.Count).End(1).Column
   
3. For i = 2 To m
   
4.     g = Cells(2, i).Value
   
5.     y = Len(g)
   
6.     n = Cells(Rows.Count, i).End(3).Row
   
7.     For j = 3 To n
   
8.         If InStr(1, Cells(j, i), g, 1) > 0 Then
   
9.             x = InStr(Cells(j, i), g)
   
10.             With Cells(j, i).Characters(Start:=x, Length:=y).Font
    
11.                 .Underline = xlUnderlineStyleSingle
    
12.                 .ColorIndex = 3
    
13.             End With
    
14.         Else
    
15.             Cells(j, i).Interior.ColorIndex = 6
    
16.         End If
    
17.     Next
    
18. Next
    
19. End Sub

复制代码

2567408563

MOY838840554 发表于 2018-12-20 16:22
Sub 替换()
    Dim rng As Range, tr&, s, sLen%, sStart%, ts$
    Set rng = Range("A1").CurrentRegi ...

已经解决了，非常感谢~

2567408563

dsmch 发表于 2018-12-20 16:39

成功替换，非常感谢~