DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
...::: Ekli Dosyayı İndirmek İçin Linki Tıklayınız :::...
https://yadi.sk/d/bljlsVPkapfY2
Sub kod()
Application.ScreenUpdating = False
Range("D:E").ClearContents
say = 2
For i = 1 To Cells(Rows.Count, "B").End(3).Row
If WorksheetFunction.CountIf(Range("B1:B" & i), Cells(i, "B")) = 1 Then
Cells(say, "D") = Cells(i, "B")
For a = 1 To Cells(Rows.Count, "A").End(3).Row
If Cells(a, "B") = Cells(say, "D") Then
metin = metin & Cells(a, "A") & ", "
End If
Next a
Cells(say, "E") = Left(metin, Len(metin) - 2)
metin = Empty
say = say + 1
End If
Next i
Application.ScreenUpdating = True
MsgBox " B i t t i "
End Sub