Looping findnext inside another loop & find

Question

I have used a loop to find the closest name to a supplier from Sheet 1 out of Sheet 2.

Dim LastRow As Long
LastRow = Sheets("BBB").Range("A" & Rows.Count).End(xlUp).Row

Dim i As Integer
For i = 2 To LastRow
Dim ra As Range
Dim a, k As Integer
a = Len(Sheets("BBB").Range("A" & i))   

Do
Set ra = Sheets("AAA").Cells.Find(What:=Left(Range("A" & i), a), LookIn:=xlValues, LookAt _
        :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
        False, SearchFormat:=False)


a = a - 1

Loop Until Not ra Is Nothing Or a = 3

If ra Is Nothing Then
Sheets("BBB").Range("C" & i).Value = a
Else
Sheets("BBB").Range("B" & i).Value = ra.Value

It works great but now I am thinking that It is possible that some occurences are twice in the sheet "AAA"

Example: Supplier in Sheet BBB: "SICK" If Sheet AAA has 2 suppliers: "SICK" and "NOSICKHERE LTD" My code will only find one of the two supplier but will not return both.

How can I use findnext to find all occurences? Anyone see a better solution?

I tried to use the following at the bottom of my code before the "next i", but I fail to use the findnext

Dim firstCellAddress As String
firstCellAddress = ra.Address

k = 1
Do

    Set ra = Sheets("AAA").Cells.FindNext()
    Sheets("BBB").Cells(i, 2 + k).Value = ra.Value

    k = k + 1

Loop While firstCellAddress <> ra.Address

Please tell me if my question is too hard to understand

Answer 1

This generates the required output.

Option Explicit

Public Sub GetMatches()

    Dim wb As Workbook, wsSource As Worksheet, wsSearch As Worksheet, masterDict As Object, arr() As Variant, i As Long
    Set wb = ThisWorkbook
    Set wsSource = wb.Worksheets("BBB")
    Set wsSearch = wb.Worksheets("AAA")
    Set masterDict = CreateObject("Scripting.Dictionary")

    With wsSource
        arr = Intersect(.Columns(1), .UsedRange)
        For i = 1 To UBound(arr, 1)
            If Not masterDict.exists(arr(i, 1)) Then masterDict.Add arr(i, 1), GetAllMatches(arr(i, 1), wsSearch)
        Next i
    End With

    Dim key As Variant
    For Each key In masterDict.keys
        Debug.Print masterDict(key)
    Next key
End Sub

Public Function GetAllMatches(ByVal findString As String, ByVal searchRng As Worksheet) As String

    Dim foundCell As Range
    Dim concatenatedString As String
    concatenatedString = vbNullString
    With Intersect(searchRng.Columns(1), searchRng.UsedRange)

        Set foundCell = .Find(findString)
        concatenatedString = foundCell

        Dim currMatch As Long
        currMatch = 0

        For currMatch = 1 To WorksheetFunction.CountIf(.Cells, "*" & findString & "*") - 1

            Set foundCell = .Find(What:=findString, After:=foundCell, _
                                  LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, _
                                  SearchDirection:=xlNext, MatchCase:=False)

            If Not foundCell Is Nothing Then
                concatenatedString = concatenatedString & "," & foundCell
            Else
                concatenatedString = foundCell
            End If
        Next currMatch
    End With    
    GetAllMatches = concatenatedString    
End Function

TestData:

AAA:

| Absinthe    |
| Antibiotics |
| Random      |
| Antisocial  |
| Antipodean  |
| Motorcycle  |
| Random      |
| Random      |
| Motorbike   |
| Random      |
| Motown      |

BBB:

| Ab   |
| Moto |

Output:

Answer 2

The code below will loop through all values in sheet B and output it's findings. I've re-used QHarr's values for my example

Option Explicit
Public Sub findValue()
    Dim firstAddress As String
    Dim c As Range, rng As Range, v As Range
    Dim tmp As Variant
    Dim j As Long

    With ThisWorkbook
        With .Sheets("AAA")
            Set rng = .Range(.Cells(1, 1), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 1))
        End With

        With .Sheets("BBB")
            For Each v In .Range(.Cells(1, 1), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 1))
                ReDim tmp(1 To rng.Rows.Count)
                j = LBound(tmp)

                Set c = rng.Find(what:=v, LookIn:=xlValues, lookat:=xlPart, MatchCase:=False)
                If Not c Is Nothing Then
                    firstAddress = c.Address
                    Do
                        tmp(j) = c.Value2
                        j = j + 1
                        Set c = rng.FindNext(c)
                    Loop While c.Address <> firstAddress And Not c Is Nothing
                    If j > 0 Then
                        ReDim Preserve tmp(LBound(tmp) To j - 1)
                        Debug.Print v & ": " & Join(tmp, ",")
                        v.Offset(0, 1).Value2 = Join(tmp, ",")
                    End If
                End If
            Next v
        End With
    End With
End Sub

---

Sheet("AAA")

Sheet("BBB") before running code

Sheet("BBB") After code run

Immediate Window after code run