Mükerrer kayıt düzenleme-2 ?

[Gorarr]

Selamlar burda ;
İsimlerin karşısında kodları var. Ancak bazı isimler 2,3 veya 4 kez
tekrarlıyor ve farklı kodlar içerebiliyor.
Yapmam gereken olay;
Birden fazla olan tüm isimlerin tek hale gelmesi ve o isimlerin tüm kodlarının yan hücrelere yazılması. Aşağıda örneklerle de göstermeye çalıştım.
Yardımlarınızı için şimdiden çok çok teşekkürler...

(Modüldeki kod= 2 ay kadar önce benzer bir sorum olmuştu ozamanlar kodlar virgülle ayrılarak yan hücreye yazılması gerekmişti. Bu kezki işlem için malesef modifiye edemedim)

 

[Orion1]

Dosyanız ektedir.
Option Base 1
Sub gruplandir_59()

Dim list(), a, z As Object, sat As Long, sut As Integer, vkey
sat = Cells(65536, "B").End(xlUp).Row
If sat < 2 Then Exit Sub
list = Range("B2:C" & sat).Value
Set z = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(list)
    If Not z.exists(list(i, 1)) Then
        z.Add list(i, 1), list(i, 2)
        Else
        z.Item(list(i, 1)) = z.Item(list(i, 1)) & "-" & list(i, 2)
    End If
Next
Erase list
Application.ScreenUpdating = False
Range("A2:C65536").Clear
sat = 2
For Each vkey In z
    Cells(sat, "B").Value = z.Item(vkey)
    sut = 3
    Cells(sat, "B").Value = vkey
    a = Split(z.Item(vkey), "-")
    For i = 0 To UBound(a, 1)
        Cells(sat, sut).Value = a(i)
        sut = sut + 1
    Next
    sat = sat + 1
Next
Set z = Nothing
Application.ScreenUpdating = True
MsgBox "İşlem tamamdır." & vbLf & "evrengizlen@hotmail.com", vbOKOnly + vbInformation, "E V R E N"
End Sub

 

[Gorarr]

Hocam ellerinize sağlık. Çok çok teşekkür ederim. Saygılar selamlar...

 

[Orion1]

Hocam ellerinize sağlık. Çok çok teşekkür ederim. Saygılar selamlar...

Rica ederim.
Bilmukabele.