Sutunda bulunan tekrarlanan degerlerı tek degere ındırme

[Alpay Black]

Arkadaslar elımde aynı kodlar defalarca kullanılmıs
ben bunu aynı kodları tek kod olarak ve kac kez k kullanıldıgını gormek ıstıyorum denedım olmadı yardımcı olursanız sevınırımdosya ektedır

 

[Ömer]

Merhaba,

Bu şekilde deneyin.

Sub Ozet_Al_Say()

    Dim d As Object, i As Long, s, deg

    Set d = CreateObject("Scripting.Dictionary")
    
    Application.ScreenUpdating = False
    Sheets("Sayfa1").Select

    For i = 2 To Cells(Rows.Count, "B").End(xlUp).Row
        deg = Cells(i, "B")
        If Not d.exists(deg) Then
            s = 1
            d.Add deg, s
        Else
            s = d.Item(deg)
            s = s + 1
            d.Item(deg) = s
        End If
    Next i

    Range("D2:C" & Rows.Count).ClearContents
    Range("D2").Resize(d.Count, 2) = _
        Application.Transpose(Array(d.keys, d.items))
        
    Application.ScreenUpdating = True

End Sub

.

 

[Alpay Black]

ömer hocam çok teşekkur ederım