Msgbox ile bilgi alma

[nadirornek]

Kod macro yardımı ile D sutununda bulunan ürün adlarından benzerlerinden kaç tane olduğunu Msgbox yardımı ile alabilirmiyim.
Tuşa bastığım zaman Msgbox'sun bana bildirmesini istiyorum.
Örnek sutunundaki ürünleri yazaçak karşısına kaç adet olduğunu yazaçak.E topla mantığı gibi.
Elma-4
Armut-1
12-2
15-1
Üzüm-1
Muz-1

 

[askm]

Öncelikle benzersiz listeyi yardımcı bir sütuna ya da diziye alın. Sonra orada, belirttiğiniz gibi etopla ile yada döngü ile toplamlarını yazdırın. En sona da msgbox olarak ekrana yansıtırsınız.

 

[nadirornek]

Kod yardımı

 

[askm]

Sub askm()
Dim son As Long
son = Range("D" & Rows.Count).End(3).Row
Application.ScreenUpdating = False
Dim alan
Set alan = Range("D3:D" & son)
alan.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range( _
        "K1"), Unique:=True
For i = 1 To Range("K" & Rows.Count).End(3).Row
    Adet = WorksheetFunction.CountIf(alan, Cells(i, "K"))
    Kelime = Kelime & Cells(i, "K") & " - " & Adet & vbLf
Next i
Application.ScreenUpdating = True
Columns("K").ClearContents
MsgBox Kelime, vbInformation, "ASKM"

End Sub

 

[nadirornek]

Teşekkürler elinize sağlık