Soru Benzersiz Değerleri Koşullu Saydırma

[ttb]

Merhaba,
Öncelikle şimdiden yardımınız için teşekkür ederim.
İçinden çıkamadığım bir husus var. Ekli örnek tabloya göre anlatmam gerekirse; B sütununda yer alan kişilerin kaç farklı renk kullandığını bulmak istiyorum; ancak her bir rengi sadece bir sefer saysın ve G sütununa, isimin yanına bulduğu sayıyı yazsın.
Örneğin Ali, mavi ve kırmızıyı ikişer kere, sarı ve eflatunu ise birer kere kullanmış. B sütununda 6 sefer Ali adı geçiyor. Ancak mevi ve kırmızıyı ikişer kere kullandığı için bunları 1 olarak saymasını ve G sütununda Ali'nin karşısına 6 değil 4 yazmasını istiyorum.
Umarım anlaşılır şekilde yazabilmişimdir.
Tekrar teşekkürler.

 

[muygun]

Merhaba;
Ekteki gibi olabilir.
İyi çalışmalar.

 

[ttb]

Kusura bakmayın, sorduğum soru ile eklediğim tablo uyumsuz olmuş, yanılttım sizi de. Eke tabloyu tekrar koydum. Benim çalışacağım orijinal tabloda 12 farklı isme karşılık gelen yaklaşık 8,000 adet rakam var. Bunların büyük kısmı eşsiz ama içinde tekrar edenler de vae.
Teşekkürler.

 

[muygun]

Merhaba;
orjinali 8000 olan kısıtlı veri ile formül kasmasını göremezsiniz.
Bence makro çözümü deneyin.
İyi çalışmalar.

 

[Ziynettin]

Alternatif makrolu çözüm.

 

[Korhan Ayhan]

Merhaba,

Özet tablo ile alternatif...

 

[veyselemre]

Sub test()
    Dim sonSat&, veri, liste, i&, say&, sira&
    
    Range("F:H").Clear
    sonSat = Cells(Rows.Count, 1).End(3).Row
    If sonSat < 2 Then Exit Sub

    veri = Range("A2:B" & sonSat).Value
    ReDim liste(0 To UBound(veri), 1 To 3)
    liste(0, 1) = "İsim"
    liste(0, 2) = "Adet"
    liste(0, 3) = "Renkler"
    
    With CreateObject("Scripting.Dictionary")
        
        For i = 1 To UBound(veri)
            
            If Not .exists(veri(i, 2) & "|" & veri(i, 1)) Then
                
                .Item(veri(i, 2) & "|" & veri(i, 1)) = Null
                
                If Not .exists(veri(i, 2)) Then
                    say = say + 1
                    .Item(veri(i, 2)) = say
                    liste(say, 1) = veri(i, 2)
                    liste(say, 2) = 1
                    liste(say, 3) = veri(i, 1)
                Else
                    sira = .Item(veri(i, 2))
                    liste(sira, 2) = liste(sira, 2) + 1
                    liste(sira, 3) = liste(sira, 3) & ", " & veri(i, 1)
                End If
            
            End If
                                
        Next i
    
    End With
    
    With Range("F1").Resize(say + 1, 3)
        .Value = liste
        .Borders.Color = rgbSilver
        .Columns.AutoFit
    End With

    MsgBox "İşlem tamam...", vbInformation
End Sub

 

[Erdem Akdemir]

Dizi formülü,

=TOPLA(--ESAYIYSA(KAÇINCI(SATIR($A$2:$A$17)-1;KAÇINCI($A$2:$A$17&F1;$A$2:$A$17&$B$2:$B$17;0);0)))