samwang

¦^´_ 1# ÅÚ½³ªd

½Ð´ú¸Õ¬Ý¬Ý¡AÁÂÁÂ
Sub test()
Dim Arr, Brr, xD, xD1, TT, n%, C%, m%, i&, k%
Set xD = CreateObject("Scripting.Dictionary")
Set xD1 = CreateObject("Scripting.Dictionary")
Arr = Range([¸ê®Æ!c1], [¸ê®Æ!a65536].End(3))
For i = 2 To UBound(Arr)
    If Arr(i, 2) = "" Then GoTo 99
    If Not xD.Exists(Arr(i, 2) & "") Then
        k = k + 1: xD(Arr(i, 2) & "") = k
    End If
99: Next
ReDim Brr(1 To UBound(Arr), 1 To xD.Count + 1)
With Sheets("§e²{ªí")
    .Range("b1").Resize(, xD.Count) = xD.keys
    For i = 2 To UBound(Arr)
        C = xD(Arr(i, 2) & "") + 1
        If xD1.Exists(Arr(i, 1)) Then
            m = xD1(Arr(i, 1))
            If IsEmpty(Brr(m, C)) Then Brr(m, C) = Arr(i, 3) Else Brr(m, C) = Brr(m, C) & "," & Arr(i, 3)
        Else
            n = n + 1: xD1(Arr(i, 1)) = n
            Brr(n, 1) = Arr(i, 1): Brr(n, C) = Arr(i, 3)
        End If
    Next
    .Range("a2").Resize(n, xD.Count) = Brr
End With
End Sub