Find vba with multiple results loop until word is found

Question

I'm trying to create a tool wherein emails were extracted under sheet 1 and account numbers are in sheet 2.

I wanted the tool to find the account number in sheet 1 and check if there's a word "contract" and it will result to True.

The problem is that the account number can have multiple results and it only gets the first result.

For example : ACCOUNT #123 is showing in A1 that have no word "contract" on it. ACCOUNG #123 is also showing in A15 that have the word "contract"

The code will not show True because it got the ACCOUNT#123 under A1

Option Explicit
Sub FindCLG()
    Dim wsI As Worksheet, ws0 As Worksheet
    Dim lRow As Long, i As Long
    Dim x As Long
    Dim aCell As Range, bCell As Range
    Dim cellad As String

    Set wsI = ThisWorkbook.Sheets("Sheet1")
    Set ws0 = ThisWorkbook.Sheets("Sheet3")
    ws0.Range("E:F").ClearContents
    lRow = ws0.Range("B" & ws0.Rows.Count).End(xlUp).Row
    
    For i = 2 To lRow
        Set aCell = wsI.Range("A:A").Find(what:=ws0.Range("b" & i).Value, LookIn:=xlValues, lookat:=xlPart, Searchorder:=xlByRows) 

        If Not aCell Is Nothing Then
            ws0.Range("E" & i).Value = "True"
            Set bCell = aCell.Offset(0, 3).Find(what:="*ontrac*", LookIn:=xlValues, lookat:=xlPart, Searchdirection:=xlNext, Searchorder:=xlByRows)

            If Not bCell Is Nothing Then
                ws0.Range("F" & i).Value = "True"
            End If
        End If
    Next i
End Sub

Answer 1

Find/FindNext is complex enough that it really should be pushed out into a separate function, otherwise it tends to obscure the main logic too much:

Sub FindCLG()
    Dim wsI As Worksheet, ws0 As Worksheet
    Dim i As Long, col As Collection, c As Range
    
    Set wsI = ThisWorkbook.Sheets("Sheet1")
    Set ws0 = ThisWorkbook.Sheets("Sheet3")
    ws0.Range("E:F").ClearContents
    
    For i = 2 To ws0.Range("B" & ws0.Rows.Count).End(xlUp).row
        Set col = FindAll(wsI.Range("A:A"), ws0.Range("b" & i).Value) 'get any/all matches
        If col.Count > 0 Then
            For Each c In col
                'use instr to check cell 3 columns over...
                If InStr(1, c.Offset(0, 3).Value, "ontrac", vbTextCompare) > 0 Then
                    ws0.Range("b" & i).Value = "True"
                    Exit For 'no need to check any other matching cells
                End If
            Next c
        End If
    Next i
End Sub

'find all cells containing `val` in range `rng`, and return as a collection
Public Function FindAll(rng As Range, val As String) As Collection
    Dim col As New Collection, f As Range
    Dim addr As String
    '## set `Find` arguments as required ###
    Set f = rng.Find(what:=val, After:=rng.Cells(rng.Cells.Count), _
        LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, _
        SearchDirection:=xlNext, MatchCase:=False)
    If Not f Is Nothing Then addr = f.Address()
    Do Until f Is Nothing
        col.Add f
        Set f = rng.FindNext(After:=f)
        If f.Address() = addr Then Exit Do 'have looped back to start...
    Loop
    Set FindAll = col
End Function

EDIT: a different (and cleaner) approach using COUNTIFS

Sub Test()
    Dim wsI As Worksheet, ws0 As Worksheet
    Dim c As Range, res
    
    Set wsI = ThisWorkbook.Sheets("Sheet1")
    Set ws0 = ThisWorkbook.Sheets("Sheet3")
    ws0.Range("E:F").ClearContents
    
    For Each c In ws0.Range("B2:B" & ws0.Range("B" & ws0.Rows.Count).End(xlUp).row).Cells
        
        res = Application.CountIfs(wsI.Range("A:A"), "*" & c.Value & "*", _
                                   wsI.Range("D:D"), "*ontrac*")
        
        c.EntireRow.Columns("F").Value = IIf(res > 0, "True", "")
    Next c
End Sub