'全匹配,就是可能是有多类的,,,
Option Explicit
Sub test()
Dim arr, brr, i As Long, j As Long, k As Long, t, tm As Single
tm = Timer
arr = Range("a2:a" & [a2].End(xlDown).Row).Value
brr = Range("b2:c" & [b2].End(xlDown).Row).Value
ReDim crr(1 To UBound(arr, 1), 1 To UBound(arr, 2)) As String
For i = 1 To UBound(arr, 1)
For j = 1 To UBound(brr, 1)
t = Split(brr(j, 1), "+")
For k = 0 To UBound(t)
If InStr(arr(i, 1), t(k)) = 0 Then Exit For
Next
If k = UBound(t) + 1 Then crr(i, 1) = crr(i, 1) & "、" & brr(j, 2)
Next
If Len(crr(i, 1)) Then crr(i, 1) = Mid(crr(i, 1), 2)
Next
Debug.Print Timer - tm
[d2].Resize(UBound(crr, 1)) = crr
Debug.Print Timer - tm
End Sub |