Gruplama ve bilgi getirme

[ReBiwAr]

Merhaba arkadaşlar,

Sorunumu içeride anlattım. Yardım edecek herkese şimdiden teşekkürler..

Hayırlı geceler

 

[ReBiwAr]

Herhalde biraz zor bir soru oldu

??

 

[Orion1]

Dosyanız ektedir.

Sub grupla()
Dim sat As Long, i As Long, k As Range, adr As String, deg As String
Dim adres As String
Sheets("Sayfa1").Select
Range("C2.C65536").ClearContents
Application.ScreenUpdating = False
sat = Cells(65536, "B").End(xlUp).Row
For i = 2 To sat
    If WorksheetFunction.CountIf(Range("B2:B" & i), Cells(i, "B").Value) = 1 Then
        Set k = Range("B1:B" & sat).Find(Cells(i, "B").Value, , xlValues, xlWhole)
        If Not k Is Nothing Then
            adr = k.Address
            Do
                deg = deg & k.Offset(0, -1).Value
                adres = adres & "," & k.Offset(0, 1).Address
                Set k = Range("B1:B" & sat).FindNext(k)
            Loop While Not k Is Nothing And k.Address <> adr
        End If
        Range(Right(adres, Len(adres) - 1)).Value = deg
        deg = ""
        adres = ""
    End If
Next
Application.ScreenUpdating = True
MsgBox "İşlem Tamamlandı." & vbLf & _
"evrengizlen@hotmail.com", vbOKOnly + vbInformation, "E V R E N"
            
End Sub

 

[ReBiwAr]

Hocam, siz bir dahisiniz

Çok teşekkürler, iyi geceler...

 

[ReBiwAr]

Hocam birde hücrelerde değişiklik olursa neleri değiştirmeliyim onuda anlatsanız

Çok mu şey istedim acaba ?

Saygılarımla

 

[ReBiwAr]

Hocam çözdüm çok teşekkür ederim...