Поиск и выделение в таблице по нескольким параметрам

If Len(currCell) Then
   newstr = Application.Trim(Replace(currCell.Value, ",", ", ", 1))
   rrCEL = Split(Application.Trim(LCase(newstr)), ", ")
      For i = LBound(rrSTR) To UBound(rrSTR)

Sub tt()
    Dim cc As Range, odict As Object, el, flag As Boolean
    Dim dblResTime As Double
    Dim stTime As Date
    Dim mstr$
 
    Set odict = CreateObject("scripting.dictionary")
    odict.comparemode = 1
 
    mstr = InputBox("Занесіть критерії для пошуку в комірках " & _
                    Chr(13) & Chr(13) & "Rem. Регістр теж не має значення." & _
                    Chr(13) & Chr(13) & "наприклад :" & _
                    Chr(13) & Chr(13) & "П     г     234     МзН" & _
                    Chr(13) & Chr(13) & _
                    "(К-сть прогалин також значення не мають!)", , "П г 234 МзН")
    stTime = Timer
 
    Application.ScreenUpdating = False
 
    ActiveSheet.Cells.Interior.ColorIndex = xlNone
 
    For Each cc In ActiveSheet.UsedRange.Cells
        flag = True
        odict.RemoveAll
        For Each el In Split(Replace(cc.Value, ",", " "))
            odict.Item(el) = 0&
        Next
        For Each el In Split(mstr)
            If Not odict.exists(el) Then flag = False
        Next
        If flag Then cc.Interior.Color = vbRed
    Next
    Application.ScreenUpdating = True
 
    dblResTime = Format(Timer - stTime, "#0.00")
    MsgBox "Час   виконання   -   " & dblResTime
 
End Sub

Sub tttt()
    Dim cc, odict As Object, el, flag As Boolean
    Dim dblResTime As Double
    Dim stTime As Date
    Dim mstr$, x&
    Dim i&, ii&, a()
 
    Set odict = CreateObject("scripting.dictionary")
    odict.comparemode = 1
 
    mstr = InputBox("Занесіть критерії для пошуку в комірках " & _
                    "ч/з прогалини (можна з комами - тоді можна i без прогалин)." & _
                    Chr(13) & Chr(13) & "Rem. Регістр теж не має значення." & _
                    Chr(13) & Chr(13) & "наприклад :" & _
                    Chr(13) & Chr(13) & "П     г     234     МзН" & _
                    Chr(13) & Chr(13) & _
                    "(К-сть прогалин також значення не мають!)", , "П  г  234  МзН")
    stTime = Timer
 
    Application.ScreenUpdating = False
    With ActiveSheet.UsedRange
        .Interior.ColorIndex = xlNone
        a = .Value
        For i = 1 To UBound(a)
            For ii = 1 To UBound(a, 2)
                cc = a(i, ii)
                x = x + 1
                If Len(cc) Then
                    flag = True
                    odict.RemoveAll
                    For Each el In Split(Replace(cc, ",", " "))
                        odict.Item(el) = 0&
                    Next
                    For Each el In Split(mstr)
                        If Not odict.exists(el) Then flag = False
                    Next
                    If flag Then .Cells(x).Interior.Color = vbRed
                End If
            Next
        Next
    End With
 
    Application.ScreenUpdating = True
 
    dblResTime = Format(Timer - stTime, "#0.00")
    MsgBox "Час   виконання   -   " & dblResTime
 
End Sub

Sub SearchAllCells_WithMyCriteries_CorrectedByHugo121()
    Dim mARR(), mRng As Range, currCell As Range, el
    Dim i&, mstr$, counter&, bFlag As Boolean
    Dim dict As Object, coll As Collection
    Dim stTime As Date, dblResTime As Double
    Application.ScreenUpdating = False
        With ActiveSheet
            .Cells.Font.Name = "Tahoma"
            .Cells.Font.Bold = False
            .Cells.Interior.ColorIndex = xlNone
            Set mRng = .UsedRange.SpecialCells(xlCellTypeConstants, 2)
        End With
    Application.ScreenUpdating = True
    ReDim mARR(1 To Application.WorksheetFunction.CountA(mRng), 1 To 2)
        For Each currCell In mRng
            counter = counter + 1
            mARR(counter, 1) = currCell.Address
            mARR(counter, 2) = currCell.Value
        Next
    mstr = func_ProcessPhrase(InputBox("Занесіть критерії для пошуку в комірках " & _
                "ч/з прогалини (можна з комами - тоді можна i без прогалин)." & _
                Chr(13) & Chr(13) & "Rem. Регістр теж не має значення." & _
                Chr(13) & Chr(13) & "наприклад :" & _
                Chr(13) & Chr(13) & "П     г     234     МзН" & _
                Chr(13) & Chr(13) & _
                "(К-сть прогалин також значення не мають!)", , "П  г  234  МзН"))
    stTime = Timer
    Set dict = CreateObject("scripting.dictionary")
    dict.comparemode = 1
    Set coll = New Collection
        For i = LBound(mARR, 1) To UBound(mARR, 1)
            bFlag = True
            dict.RemoveAll
                For Each el In Split(func_ProcessPhrase(CStr(mARR(i, 2))), _
                                                                        "," & Space(1))
                    dict.Item(el) = 0&
                Next
                For Each el In Split(mstr, "," & Space(1))
                    If Not dict.exists(el) Then bFlag = False
                Next
            If bFlag Then coll.Add Item:=mARR(i, 1)
    Next
    Application.ScreenUpdating = False
        For Each el In coll
            With Range(el)
                .Interior.ColorIndex = 35
                .Font.Bold = True
                .Font.Name = "Comic Sans MS"
            End With
        Next
    With ActiveSheet
        .Columns.AutoFit
    End With
    Application.ScreenUpdating = True
    dblResTime = Format(Timer - stTime, "#0.00")
    MsgBox "Час   виконання   -   " & dblResTime
End Sub
 
Private Function func_ProcessPhrase(fStr As String)
' Перетворює фрази на зразок " as,bcd, 125,   x18m" або _
    ' "as   bcd 125  x18m     " -  до вигляду "as, bcd, 125, x18m"
    fStr = LCase(Replace(Application. _
                Trim(Replace(Application.Trim(fStr), ",", " ", 1)), " ", ", ", 1))
    func_ProcessPhrase = fStr
End Function