我使用循环从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
如果我的问题太难理解,请告诉我
这会生成所需的输出。
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 |
输出:
下面的代码将遍历表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