sutunlar arası fark

[sugarkizmerve]

Merhaba Arkadaşlar
ilk sorumu sorma heyecanındayım : )
sorum şu :
a sutununda ürün kodlarım var
b sutununda renklerim var şu şekilde
a - b
1000 - beyaz
1000 - sarı
1000 - kırmızı
1200 - beyaz
1200 - yeşil

istediğim şu sonucu vermesi
c -d
1000 - beyaz sarı kırmızı
1200 - beyaz yeşil

bunu yapacak bir formül makro yardımcı olursanız çok sevinirim

 

[Orion1]

Dosyanız ektedir.

Option Base 1
Sub test59()
Dim z As Object, list(), i As Long, myarr()
list = Range("A2:B" & Cells(Rows.Count, "A").End(xlUp).Row).Value
ReDim myarr(1 To 2, 1 To UBound(list(), 1))
Set z = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
Range("E:E").ClearContents
For i = 1 To UBound(list(), 1)
    If Not z.exists(list(i, 1)) Then
        n = n + 1
        z.Add (list(i, 1)), n
        myarr(1, n) = list(i, 1)
    End If
    myarr(1, z.Item(list(i, 1))) = myarr(1, z.Item(list(i, 1))) & " " & list(i, 2)
Next
Erase list()
Set z = Nothing
Range("E2").Resize(n, 2) = Application.Transpose(myarr)
Erase myarr()
Application.ScreenUpdating = True
MsgBox "İşlem tamamdır." & vbLf & "evrengizlen@hotmail.com", vbOKOnly + vbInformation, Application.UserName
End Sub

 

[sugarkizmerve]

teşekkür ederim tam istediğim gibi
çok makbule geçti