­ã´£³¡ªL

¨âÄ榡:
Sub test_01()
Dim Arr, xD, i&, T$, T2$, R&, N&
Set xD = CreateObject("Scripting.Dictionary")
Arr = Range([a1], [b65536].End(3))
For i = 2 To UBound(Arr)
    T = Arr(i, 1): T2 = Arr(i, 2): R = xD(T)
    If T = "" Or T2 = "" Then GoTo 99
    If R > 0 Then Arr(R, 2) = Arr(R, 2) & "¡B" & T2: GoTo 99
    N = N + 1: R = N + 1: xD(T) = R
    Arr(R, 1) = Arr(i, 1):  Arr(R, 2) = T2
99: Next i
Range("d1").Resize(N + 1, 2) = Arr
End Sub

­ã´£³¡ªL

¦hÄ榡:
Sub test_02()
Dim Arr, Brr, xD, i&, T$, T2$, R&, C%, Cx%, N&
Set xD = CreateObject("Scripting.Dictionary")
Arr = Range([a1], [b65536].End(3))
ReDim Brr(1 To UBound(Arr), 1 To 200)
For i = 2 To UBound(Arr)
    T = Arr(i, 1): T2 = Arr(i, 2)
    If T = "" Or T2 = "" Then GoTo 99
    R = xD(T):  C = xD(T & "/c")
    If R = 0 Then N = N + 1: R = N + 1: xD(T) = R: Brr(R, 1) = Arr(i, 1)
    C = C + 1: xD(T & "/c") = C: Brr(R, C + 1) = T2
    If C > Cx Then Cx = C: Brr(1, Cx + 1) = "­q³æ(" & Cx & ")"
99: Next i
Brr(1, 1) = "µo²¼¸¹½X"
Range("g1").Resize(N + 1, Cx + 1) = Brr
End Sub