複数の単語を含むようにvba .FINDを展開する

Question

次のコードは、ユーザーがユーザーフォームのテキストボックスに入力してリストをフィルタリングする際に範囲をループします。私はこれを展開したいので、ユーザーは "word1 word2 word3"と入力して、すべての入力された単語のすべての一致を得ることができます。現時点では一度に1単語しか使用できません。

Private Sub Search() 

    Dim Cell As Range 
    Dim sAddr As String 
    Dim keepers() 

    Dim sh As Worksheet 

    Set sh = ThisWorkbook.Sheets("data") 

    'Load alle 
    Populateriskissuelist 

    'Test for search string 
    If Me.txtSearch.Value = vbNullString Then 
     Exit Sub 
    End If 

    Set Cell = sh.Range(sh.Cells(2, 1), sh.Cells(getLastRowOf(sh), getLastColumnOf(sh, 1))).Find(_ 
    What:=Me.txtSearch.Text, _ 
    After:=sh.Cells(getLastRowOf(sh), getLastColumnOf(sh, 1)), _ 
    LookIn:=xlValues, _ 
    LookAt:=xlPart, _ 
    SearchOrder:=xlByColumns, _ 
    SearchDirection:=xlNext, _ 
    MatchCase:=False) 

     If Not Cell Is Nothing Then 
      sAddr = Cell.Address 
      Do 
       'Save in array 
       ReDim Preserve keepers(k) 
       keepers(k) = sh.Cells(Cell.Row, 1).Value 'ID 
       k = k + 1 

       Set Cell = sh.Range(sh.Cells(2, 1), sh.Cells(getLastRowOf(sh), getLastColumnOf(sh, 1))).FindNext(Cell) 

      Loop While Cell.Address <> sAddr 
     End If 

    'Select found items 
    If Not IsVarArrayEmpty(keepers) Then 
     For i = LBound(keepers) To UBound(keepers) 
      For j = 0 To Me.lstRiskissuelist.ListCount - 1 
       If Me.lstRiskissuelist.List(j, 0) = keepers(i) Then 
        Me.lstRiskissuelist.selected(j) = True 
       End If 
      Next j 
     Next i 
    End If 

    'delete non-selected 
    With Me.lstRiskissuelist 
     If .ListCount > 0 Then 
      For i = .ListCount - 1 To 0 Step -1 
       If .selected(i) = False Then 
        .RemoveItem (i) 
       End If 
      Next i 
     End If 
    End With 

    'Clean up 
    Set Cell = Nothing 
    Set sh = Nothing 
    Erase keepers 

    End Sub 

Answer 1

私はこの醜いチェックルーチンでそれをやった...

For i = 2 To lastRow 

    sh.Range("BO2:BO100").ClearContents 

    For j = 1 To lastCol 
     For k = 2 To sh.Range("BN50").End(xlUp).Row 
      If InStr(1, sh.Cells(i, j).Value, sh.Range("BN" & k).Value, vbTextCompare) Then 
        sh.Range("BO" & k).Value = "check" 
      End If 
     Next k 
    Next j 

    If Application.WorksheetFunction.CountA(sh.Range("BN2:BN100")) = Application.WorksheetFunction.CountA(sh.Range("BO2:BO100")) Then 
     sh.Range("BP" & i).Value = "Include" 
     'Include ROWNUMBER in cUnique 
     On Error Resume Next 
       cUnique.Add i, CStr(i) 
     On Error GoTo 0 
    Else 
     sh.Range("BP" & i).Value = "Exclude" 
    End If 
Next i