在另一个循环中循环findnext并查找

Question

我使用循环从Sheet 2中的Sheet 1中找到与供应商最接近的名称。

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

它工作得很好，但现在我认为在“AAA”表中有些事件可能是两次

示例：表BBB中的供应商：“SICK”如果表AAA有2个供应商：“SICK”和“NOSICKHERE LTD”我的代码只会找到两个供应商中的一个，但不会同时返回两个。

如何使用findnext查找所有出现的内容？有谁看到更好的解决方案？

我尝试在“下一个”之前在我的代码底部使用以下内容，但是我没有使用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

如果我的问题太难理解，请告诉我

Answer 1

这会生成所需的输出。

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

测试数据：

AAA：

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

BBB：

| Ab   |
| Moto |

输出：

Answer 2

下面的代码将遍历表B中的所有值并输出它的结果。我为我的例子重新使用了QHarr的值

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