查找并突出显示包含特定文本的单元格

Question

我对VBA还是很陌生，我试图创建一个Sub，该Sub可以查找并突出显示工作表中包含特定文本的所有单元格。

在此link中，我以Pradeepta Pradhan的代码为模型建模。

我写的字幕很有效，但是速度非常慢。关于如何加快速度或清理代码的任何提示？

Sub Find_Highlight_Comments3()
    Dim WS As Worksheet
    Dim Rng As Range
    Dim Match As Range
    Dim Comment As String

    Set WS = ActiveWorkbook.Worksheets("Report Sheet 1")
    Set Rng = WS.UsedRange
    Comment = ("insoluble residue")
    Comment = ("non-gaussian")
    Comment = ("empty source well")
    Comment = ("source vial not received")
    Comment = ("foreign object")
    Comment = ("lacks nitrogen")
    Comment = ("lacks molecular")
    Comment = ("could not be assayed")
    Comment = ("not pass through Millipore filter")
    For Each Rng In Rng
    With Rng
        Set Match = WS.Cells.Find(What:=Comment, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
            If Not Match Is Nothing Then
                Match.Interior.Color = RGB(255, 255, 0)
            End If
    End With
    Next Rng
End Sub

Answer 1

对您的代码进行少量修改。正如您提到Pradeepta Pradhan的帖子时，我已经添加了其他行以红色字体突出显示注释文本。您可以参考同一篇文章下方的Siddharth's post。

我已将所有这些评论放入评论数组。如果要添加两个以上注释，则首先将redim语句更改为10。请注意，数组从索引0开始。此外，如果要查找同一注释的所有后续出现，仅find是不够的。因此，还添加了findnext。

Sub Find_Highlight_Comments3()
Dim WS As Worksheet
Dim Match As Range
Dim Comment() As String

Set WS = ActiveWorkbook.Worksheets("Report Sheet 1")

ReDim Comment(8)
    Comment(0) = "insoluble residue"
    Comment(1) = "non-gaussian"
    Comment(2) = "empty source well"
    Comment(3) = "source vial not received"
    Comment(4) = "foreign object"
    Comment(5) = "lacks nitrogen"
    Comment(6) = "lacks molecular"
    Comment(7) = "could not be assayed"
    Comment(8) = "not pass through Millipore filter"

For i = LBound(Comment) To UBound(Comment)
Set Match = WS.Cells.Find(What:=Comment(i), LookIn:=xlValues, _
    LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
    MatchCase:=False, SearchFormat:=False)

    If Not Match Is Nothing Then
    FirstAddress = Match.Address
        Do
        sPos = InStr(1, Match.Value, Comment(i))
        sLen = Len(Comment(i))
        Match.Characters(Start:=sPos, Length:=sLen).Font.Color = RGB(255, 0, 0)
        Match.Interior.Color = RGB(255, 255, 0)
        Set Match = WS.Cells.FindNext(Match)
        Loop While Not Match Is Nothing And Match.Address <> FirstAddress
    End If
Next
End Sub