Поиск ячеек, в которых присутствуют все значения фиксированного массива

Question

У меня есть массив с фиксированными значениями. Как найти ячейки в столбце B, которые содержат все значения 'String', присутствующие в массиве?

Вот мой код

With Worksheets("Data")
    Dim kwrSets As Variant
    .Activate
    kwrSets = .Range("B2:B" & Application.WorksheetFunction.Max(2, .Range("A100000").End(xlUp).Row)).Value
    For k = LBound(kwrSets) To UBound(kwrSets)
        For i = LBound(arr) To UBound(arr)
            Delete entire row if all values of arr not found in kwrSets
        Next i
    Next k
End With

Ниже приведен обновленный код, основанный на ответе ниже, но в строке inStr выдается ошибка «Subscript out of range».

Sub Extractor()
Dim ws As Worksheet, wsd As Worksheet
Dim cell As Variant
Dim tmp As Variant
Dim blnFound As Boolean
Dim j As Long, i As Long
Dim kwrSets() As Variant
Dim arr() As String

Set ws = Worksheets("Sheet1")
With ws
    .Activate
    For Each cell In .Range("A1:A" & .Cells(.Rows.Count, "B").End(xlUp).Row)
        If (cell.Offset(0, 2) = 1) Then
            tmp = tmp & cell & "|"
        End If
    Next cell
    If Len(tmp) > 0 Then tmp = Left(tmp, Len(tmp) - 1)
    arr = Split(tmp, "|")
End With

Set wsd = Worksheets("Data")
With wsd
    .Activate
    kwrSets = .Range("B2:B" & Application.WorksheetFunction.Max(2, .Range("A100000").End(xlUp).Row)).Value
    For k = LBound(kwrSets) To UBound(kwrSets)
        blnFound = True
        For i = LBound(arr) To UBound(arr)
            If InStr(kwrSets(j, 1), arr(i)) = 0 Then
                blnFound = False
                Exit For
            End If
        Next i
    Next k
End With

End Sub

Answer 1

Ниже приведен некоторый код VBA, который переносит все данные из столбца B в массив, а затем зацикливает этот массив, проверяя наличие каждого из элементов в массиве поиска. Если какой-либо из элементов поиска не найден, он выходит из этого l oop. Если все элементы найдены, то она подсвечивает ячейку.

Sub sFindArray()
    Dim ws As Worksheet
    Dim aSearch() As Variant
    Dim aData() As Variant
    Dim lngLoop1 As Long
    Dim lngLoop2 As Long
    Dim lngFirstRow As Long
    Dim lngLastRow As Long
    Dim lngLBound As Long
    Dim lngUBound As Long
    Dim blnFound As Boolean
    aSearch = Array("a", "b", "c")
    lngLBound = LBound(aSearch)
    lngUBound = UBound(aSearch)
    Set ws = Worksheets("Sheet1")
    lngLastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row
    aData() = ws.Range("B1:B" & lngLastRow)
    lngFirstRow = LBound(aData, 1)
    lngLastRow = UBound(aData, 1)
    For lngLoop1 = lngFirstRow To lngLastRow
        blnFound = True
        For lngLoop2 = lngLBound To lngUBound
            If InStr(aData(lngLoop1, 1), aSearch(lngLoop2)) = 0 Then
                blnFound = False
                Exit For
            End If
        Next lngLoop2
        If blnFound = True Then
            ws.Cells(lngLoop1, 2).Interior.Color = vbRed
        End If
    Next lngLoop1
End Sub

С уважением,