EXcel VBA 批量查找关键词，并着色

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