..::.. En çok Tekrarlanan İLK 9 Değeri Listeleme ..::..

[Ömer BARAN]

Konuyu kapatmışsınız ama ben bir örnek dosya daha hazırlamıştım. Boşa gitmesin. İnceleyiniz.
Not : ................. deneyip hızı test ediniz.

[SIZE="2"]Option Explicit
Sub BENZERSİZ_VERİLERİ_LİSTELE()
......................
    Liste(1) = S1.Range("I8:I" & Son).Value2
    Liste(2) = S1.Range("M8:M" & Son).Value2
    Liste(3) = S1.Range("N8:N" & Son).Value2
    Liste(4) = S1.Range("Q8:Q" & Son).Value2
    Liste(5) = S1.Range("EA8:EZ" & Son).Value2
    
    Set Dizi = CreateObject("Scripting.Dictionary")

    For X = 1 To 5
        For Y = 1 To UBound(Liste(X))
            For Z = 1 To UBound(Liste(X), 2)
                If Liste(X)(Y, Z) <> "" Then
                    If Not Dizi.Exists(Liste(X)(Y, Z)) Then
                        Dizi.Add Liste(X)(Y, Z), 1
                    Else
                        Dizi.Item(Liste(X)(Y, Z)) = Dizi.Item(Liste(X)(Y, Z)) + 1
                    End If
                End If
            Next
        Next
        
        S2.Cells(2, X + 1).Resize(Dizi.Count, 2) = Application.Transpose(Array(Dizi.Keys, Dizi.Items))
        S2.Range(S2.Cells(1, X + 1), S2.Cells(S2.Rows.Count, X + 2)).Sort S2.Cells(1, X + 2), xlDescending, , , , , , xlYes
        
        [COLOR="red"][B]Adet = S1.Range[/B][/COLOR]("N4")
        
        For Z = 2 To Adet + 1
            If S2.Cells(Z, X + 1) <> "" Then
                S2.Cells(Z, 1) = Z - 1
                S2.Cells(Z, X + 1).AddComment "Tekrar Sayısı :   " & Format(S2.Cells(Z, X + 2).Text, "#,##0")
            End If
        Next
        
        S2.Range(S2.Cells(Adet + 2, X + 1), S2.Cells(S2.Rows.Count, X + 2)).ClearContents
        S2.Range("G:G").ClearContents
        
        Dizi.RemoveAll
    Next
.........................
    Set S1 = Nothing
    Set S2 = Nothing
...........................
End Sub[/SIZE]

Sayın AYHAN, tekrar merhabalar.
Bir hususu sormak istiyorum.
Aynı belge üstünde düşünüyordum ve yukarıdaki sıklık sayma, en çok tekrarlanandan en az tekrarlanana doğru, koddaki ADET değişkenine verilen değer sayısı kadar sıralama ve her biri için kendi sütununda tekrarlanma sayılarının hücre açıklaması olarak eklenmesi işlemini inanılmaz hızda yapan yukarıdaki kodu yeni duruma göre kendime uyarlamaya çalışırken bir sorunla karşılaştım.
Yazdığınız makronun çalışma mantığı yanlış anlamadıysam, sayma işleminden sonra, en çok tekrarlanan ilk ADET kadar değişkeni sütuna yazıyor, sonra da hücre açıklaması olarak ekleyeceği tekrarlanma sayısını, sağındaki hücreye yazıyor ve ardından hücre açıklaması olarak ekliyor.
Sorun şu ki; sütunlardan birinde örneğin 50 farklı değer var, bunlardan en çok tekrarlanan ADET kadar değişkeni listeleyip, hücre açıklamasına ekleyeceği sayıyı sağındaki hücreye yazdıktan sonra bunları açıklama olarak ekliyor ve ardından bir sonraki sütuna geçiyor.
Ancak bu sütundaki değişken sayısı ADET değeri olarak verdiğimiz sayıdan az ise; bir önceki sütun hücre açıklamasında kullanmak için yazdığı değerleri temizlemiyor.
Sizin hazırlamış olduğunuz örnek dosya üzerinde değişiklik yaparak durumu anlaşılır hale getirdim.
Ektaki dosyaya bakabilirseniz sevinirim.
Özet sayfasındaki kırmızı renge boyadığım hücrelerdeki değerlerin orada olmaması gerekiyor.
Bu sorunu çözmek için kodda nereyi nasıl değiştirmeliyim acaba?
İyi çalışmalar.

 

[Korhan Ayhan]

Kodu aşağıdaki gibi değiştirip deneyiniz.

Eklemeyi kırmızı renkle belirttim.

Option Explicit

Sub BENZERSİZ_VERİLERİ_LİSTELE()
    Dim S1 As Worksheet, S2 As Worksheet
    Dim Son As Long, X As Long, Y As Long, Z As Long, Adet As Long
    Dim Liste(1 To 5), Dizi As Object, Zaman As Double
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    
    Zaman = Timer
    
    Set S1 = Sheets("Veri")
    Set S2 = Sheets("Özet")
    
    S2.Range("A2:F" & S2.Rows.Count).ClearContents
    S2.Range("A2:F" & S2.Rows.Count).ClearComments
    
    S2.Range("K1") = Now
    
    On Error Resume Next
    Son = S1.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    If Son = 0 Then Son = 10000
    On Error GoTo 0
    
    Liste(1) = S1.Range("I8:I" & Son).Value2
    Liste(2) = S1.Range("M8:M" & Son).Value2
    Liste(3) = S1.Range("N8:N" & Son).Value2
    Liste(4) = S1.Range("Q8:Q" & Son).Value2
    Liste(5) = S1.Range("EA8:EZ" & Son).Value2
    
    Set Dizi = CreateObject("Scripting.Dictionary")

    For X = 1 To 5
        For Y = 1 To UBound(Liste(X))
            For Z = 1 To UBound(Liste(X), 2)
                If Liste(X)(Y, Z) <> "" Then
                    If Not Dizi.Exists(Liste(X)(Y, Z)) Then
                        Dizi.Add Liste(X)(Y, Z), 1
                    Else
                        Dizi.Item(Liste(X)(Y, Z)) = Dizi.Item(Liste(X)(Y, Z)) + 1
                    End If
                End If
            Next
        Next
        
        S2.Cells(2, X + 1).Resize(Dizi.Count, 2) = Application.Transpose(Array(Dizi.Keys, Dizi.Items))
        S2.Range(S2.Cells(1, X + 1), S2.Cells(S2.Rows.Count, X + 2)).Sort S2.Cells(1, X + 2), xlDescending, , , , , , xlYes
        
        Adet = S1.Range("N4")
        
        For Z = 2 To Adet + 1
            If S2.Cells(Z, X + 1) <> "" Then
                S2.Cells(Z, 1) = Z - 1
                S2.Cells(Z, X + 1).AddComment "Tekrar Sayısı :   " & Format(S2.Cells(Z, X + 2).Text, "#,##0")
                [COLOR="Red"]S2.Cells(Z, X + 2).ClearContents[/COLOR]
            End If
        Next
        
        S2.Range(S2.Cells(Adet + 2, X + 1), S2.Cells(S2.Rows.Count, X + 2)).ClearContents
        S2.Range("G:G").ClearContents
        
        Dizi.RemoveAll
    Next
    
    S2.Cells.EntireColumn.AutoFit

    S2.Range("K2") = Format(Timer - Zaman, "0.0000000") & " Saniye"

    Set S1 = Nothing
    Set S2 = Nothing

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True

    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[Ömer BARAN]

Kodu aşağıdaki gibi değiştirip deneyiniz. Eklemeyi kırmızı renkle belirttim.

Option Explicit
Sub BENZERSİZ_VERİLERİ_LİSTELE()
......................................
        
        For Z = 2 To Adet + 1
            If S2.Cells(Z, X + 1) <> "" Then
                S2.Cells(Z, 1) = Z - 1
                S2.Cells(Z, X + 1).AddComment "Tekrar Sayısı :   " & Format(S2.Cells(Z, X + 2).Text, "#,##0")
                [COLOR="Red"]S2.Cells(Z, X + 2).ClearContents[/COLOR]
            End If
        Next
.......................................
End Sub

Sayın AYHAN teşekkürler. Sorun düzeldi.

 

[Erdem Akdemir]

Korhan bey ve Zeki bey güzel paylaşımlar için elinize sağlık.