DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
Sub benzerbirlestir()
Application.ScreenUpdating = False
say = 1
For i = 1 To Range("d65536").End(3).Row
If WorksheetFunction.CountIf(Range("d:d"), Cells(i, "d")) >= 1 Then
Cells(say, "f") = Cells(i, "e")
For j = 1 To Range("d65536").End(3).Row
If Cells(j, "d") = Cells(say, "D") Then
hcr = hcr & Cells(j, "e") & ", "
End If
Next j
Cells(say, "f") = Left(hcr, Len(hcr) - 2)
hcr = Empty
say = say + 1
End If
Next i
Application.ScreenUpdating = True
End Sub