Sub Findcolour() ' ' Findcolour Macro ' 宏由 Haifeng 录制,时间: 2021/10/07 ' ' mword = Trim(InputBox("请输入关键字:")) n = Len(mword) 'Cells.Font.Color = 0 'Cells.Interior.Color = xlNone With ActiveSheet.Cells Set c = .Find(mword, LookIn:=xlValues) If Not c Is Nothing Then firstAddress = c.Address Do c.Interior.Color = RGB(255, 255, 0) n1 = InStr(c.Value, mword) If n1 = 1 Then c.Characters(Start:=1, Length:=n).Font.Color = 255 c.Characters(Start:=n + 1, Length:=Len(c.Value) - n).Font.Color = 0 ElseIf n1 + n = Len(c.Value) Then c.Characters(Start:=1, Length:=Len(c.Value) - n).Font.Color = 0 c.Characters(Start:=Len(c.Value) - n + 1, Length:=n).Font.Color = 255 Else c.Characters(Start:=1, Length:=n1 - 1).Font.Color = 0 c.Characters(Start:=n1, Length:=n).Font.Color = 255 c.Characters(Start:=n1 + n + 1, Length:=Len(c.Value) - n1 - n).Font.Color = 0 End If Set c = .FindNext(c) Loop While Not c Is Nothing And c.Address <> firstAddress End If End With End Sub |
|