突出显示单元格文本中含有词库的内容

'使用颜色和加粗来突出显示词库中的文字
Sub ColorandBold()
 Dim myCell As Range
 Dim myRng As Range
 Dim FirstAddress As String
 Dim iCtr As Long
 Dim letCtr As Long
 Dim startrow As Long    '开始的单元格区域位置
 Dim endrow As Long    ' 结束的单元格区域位置
 Dim startcolumn As Integer    '开始列
 Dim endcolumn As Integer    '结束列
 Dim myWords
 
 '设置要应用突出显示词库文字的单元格区域
 '你可以根据你的需要来修改
 startrow = 2
 endrow = 5
 startcolumn = 1
 endcolumn = 2
 Set myRng = Range(Cells(startrow, startcolumn), Cells(endrow, endcolumn))
 
 '设置词库
 '即想要添加颜色和加粗的词语
 myWords = Array("完美Excel", "excelperfect", "Excel")
 
 '开始主循环---------------------------------------
 For iCtr = LBound(myWords) To UBound(myWords)
   '忽略错误
   On Error Resume Next
   With myRng
     Set myCell = .Find(What:=myWords(iCtr), After:=.Cells(1), _
        LookIn:=xlValues, LookAt:=xlPart, _
        SearchOrder:=xlByRows, _
        SearchDirection:=xlNext, _
        MatchCase:=False)
     '检查
     If Not myCell Is Nothing Then
       FirstAddress = myCell.Address
 
       Do
         For letCtr = 1 To Len(myCell.Value)
           If StrComp(Mid(myCell.Value, letCtr, _
               Len(myWords(iCtr))), _
               myWords(iCtr), vbTextCompare) = 0 Then
             myCell.Characters(Start:=letCtr, _
               Length:=Len(myWords(iCtr))) _
               .Font.ColorIndex = 5
           End If
         Next letCtr
         For letCtr = 1 To Len(myCell.Value)
           If StrComp(Mid(myCell.Value, letCtr, _
               Len(myWords(iCtr))), _
               myWords(iCtr), vbTextCompare) = 0 Then
              myCell.Characters(Start:=letCtr, _
                Length:=Len(myWords(iCtr))) _
                .Font.FontStyle = "Bold"
           End If
         Next letCtr
 
         '获取相一个地址
         Set myCell = .FindNext(myCell)
       Loop While Not myCell Is Nothing _
         And myCell.Address <> FirstAddress
     End If
   End With
 Next iCtr
End Sub