Üç Sütunlu Karşılaştırma

[Gold_Savt]

Problemin özeti
"B sütunundaki kişiler, C sütununda ki çeşitliliğe göre, D sütunundaki değeri kaç kere almış?"
Teşekkürler.

 

[Necdet]

Merhaba,
Pivot Table ile hazırlanmış dosya işinize gelirse kullanabilirsiniz. Daha pratiktir.

 

[Gold_Savt]

Necdet Hocam Pivot Table projeme uygun düşmedi malesef. Makro olursa uygun olacak muhtemelen

 

[Necdet]

Necdet Hocam Pivot Table projeme uygun düşmedi malesef. Makro olursa uygun olacak muhtemelen

Bence Pivot Tablo daha hızlı olurdu.
Aşağıdaki kodları bir modüle kopyalayıp deneyiniz. Tam kontrol yapmadım, sonucu merak ediyorum.

Public Sub Listele()
                        'Referanslardan Microsoft Scripting Runtime SEÇİLİ OLMALI
Dim arrV As Variant, _
    arr  As Variant, _
    i    As Long, _
    j    As Integer, _
    k    As Long, _
    m    As Integer, _
    colA As New Collection, _
    colI As New Collection, _
    dic  As New Dictionary, _
    ws   As Worksheet, _
    deg(1 To 3) As String

deg(1) = "İyi": deg(2) = "Orta": deg(3) = "Kötü"

Set ws = Sheets("Anasayfa")
ws.Range("I1").CurrentRegion.Clear


arrV = Sheets("Anasayfa").Range("A1").CurrentRegion.Value

For i = 3 To UBound(arrV, 1)
    arrV(i, 2) = BKH(arrV(i, 2))
    arrV(i, 3) = BKH(arrV(i, 3))
    arrV(i, 4) = BKH(arrV(i, 4))
   
    colA.Add arrV(i, 2), arrV(i, 2)
    On Error Resume Next
    colI.Add arrV(i, 3), arrV(i, 3)
    On Error Resume Next
Next i

ReDim arr(1 To colA.Count + 2, 1 To (colI.Count * 3) + 1)

j = 1
For i = 1 To colI.Count
    j = j + 1
    arr(1, j) = colI(i)
    arr(2, j) = deg(1)
    j = j + 1
    arr(2, j) = deg(2)
    j = j + 1
    arr(2, j) = deg(3)
Next i
arr(2, 1) = "ADI SOYADI"

j = 2
For i = 3 To UBound(arrV, 1)
    If Not dic.Exists(arrV(i, 2)) Then
        j = j + 1
        dic.Add arrV(i, 2), j
        arr(j, 1) = arrV(i, 2)
        m = Kacinci(arrV(i, 3), colI)
        m = (m - 1) * 3 + 2
        If arrV(i, 4) = "ORTA" Then
            m = m + 1
        ElseIf arrV(i, 4) = "KÖTÜ" Then
            m = m + 2
        End If
        arr(j, m) = 1
    Else
        k = dic.item(arrV(i, 2))
        m = Kacinci(arrV(i, 3), colI)
        m = (m - 1) * 3 + 2
        If arrV(i, 4) = "ORTA" Then
            m = m + 1
        ElseIf arrV(i, 4) = "KÖTÜ" Then
            m = m + 2
        End If
        arr(k, m) = arr(k, m) + 1
    End If
Next i

ws.Range("J1").Resize(UBound(arr, 1), UBound(arr, 2)) = arr

End Sub

Private Function BKH(Sozcuk As Variant, Optional Tip As Integer = 2) As String

    'Tip    1. Küçük Harf
    '       2. Büyük Harf
    '       3. Yazım Düzeni
   
    If Tip = 1 Then
        BKH = Evaluate("=LOWER(" & """" & Sozcuk & """" & ")")
    ElseIf Tip = 2 Then
        BKH = Evaluate("=UPPER(" & """" & Sozcuk & """" & ")")
    Else
        BKH = Application.WorksheetFunction.Proper(Sozcuk)
    End If
   
End Function

Private Function Kacinci(Aranan As Variant, coll As Collection) As Long
    Dim i As Long
   
    For i = 1 To coll.Count
        If Aranan = coll(i) Then Exit For
    Next
    Kacinci = i
End Function

 

[Korhan Ayhan]

Alternatif...

 

[Gold_Savt]

Bence Pivot Tablo daha hızlı olurdu.
Aşağıdaki kodları bir modüle kopyalayıp deneyiniz. Tam kontrol yapmadım, sonucu merak ediyorum.

kullandığım excel .xls olduğundan sanırım çalışmadı.

Alternatif...

Korhan Hocam, problem emeklerinizle çözülmüş oldu. Çok çok teşekkürler.

 

[Necdet]

kullandığım excel .xls olduğundan sanırım çalışmadı.

Ben size Pivot Tablo önerdiğimde uygun değil gibi laf etmiştiniz, Korhan bey Pivot Kullanmış Sorun çözüldü diyorsunuz.
Demekki pivotu da makroya yaptırmak gerekiyormuş
Benim kodlarımın çalışmadığını söylediniz, Dosya ekte