samwang

¦^´_ 1# hycn


    Sub test()
    Dim arr, ´Ñ½L(1 To 2000, 1 To 2), i%
    Dim d As Object, d1 As Object
    Set d = CreateObject("scripting.dictionary")
    Set d1 = CreateObject("scripting.dictionary")
    arr = Range("b1", [a65536].End(xlUp))

    For i = 1 To UBound(arr)
        xR = arr(i, 1) & arr(i, 2)
        If d.Exists(arr(i, 1)) Then
            If d1.Exists(xR) Then GoTo 100
            ¦C = d(arr(i, 1))
            ´Ñ½L(¦C, 2) = ´Ñ½L(¦C, 2) & "," & arr(i, 2)
        Else
            k = k + 1
            d(arr(i, 1)) = k
            ´Ñ½L(k, 1) = arr(i, 1)
            ´Ñ½L(k, 2) = arr(i, 2)
        End If
        d1(xR) = arr(i, 1) & arr(i, 2)
100:    Next
    Range("D1").Resize(k, 2) = ´Ñ½L
End Sub