Option Explicit
Sub abc()
Dim a, i, j, k, t, n
a = Range("a2:b" & [a2].End(xlDown).Row).Value
ReDim b(1 To 2 ^ UBound(a), 1 To 3)
b(2, 1) = "、" & a(1, 1): b(2, 2) = "、" & a(1, 2)
b(2, 3) = 1: n = 2
For i = 2 To UBound(a, 1)
For j = n + 1 To 2 * n
b(j, 1) = b(j - n, 1) & "、" & a(i, 1)
b(j, 2) = b(j - n, 2) & "、" & a(i, 2)
b(j, 3) = b(j - n, 3) + 1
Next
n = n * 2
Next
For i = 2 To UBound(b): b(i, 2) = b(i, 2) & "、": Next
Call qsort(b, 2, UBound(b), 1, 3, 3)
a = Range("f2:j" & [f2].End(xlDown).Row).Value
For i = 1 To UBound(a)
t = Split(a(i, 2), "、")
a(i, 4) = Empty: a(i, 5) = Empty
For j = 2 To UBound(b)
For k = 0 To UBound(t)
If InStr(b(j, 2), "、" & t(k) & "、") = 0 Then Exit For
Next
If k = UBound(t) + 1 Then
a(i, 4) = b(j, 3): a(i, 5) = Mid(b(j, 1), 2)
Exit For
End If
Next
Next
[f2].Resize(UBound(a), UBound(a, 2)) = a
End Sub
Function qsort(a, first, last, left, right, key)
Dim i As Long, j As Long, k As Long, x, t
i = first: j = last: x = a((first + last) \ 2, key)
While i <= j
While a(i, key) < x: i = i + 1: Wend
While x < a(j, key): j = j - 1: Wend
If i <= j Then
For k = left To right
t = a(i, k): a(i, k) = a(j, k): a(j, k) = t
Next
i = i + 1: j = j - 1
End If
Wend
If first < j Then qsort a, first, j, left, right, key
If i < last Then qsort a, i, last, left, right, key
End Function