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

[Zeki Gürsoy]

Geçici sayfaya gerek yok. Kodu yarın revize edeceğim.

 

[Ömer BARAN]

Eyvallah, sizi yoruyorum ama kusura bakmayınız.
Anladığım kadarıyla muhasebe konusunda çalışıyorsunuz, elinize düşen defterin, kaydı tutanın vay haline.

 

[Muhammet Okumuş]

Konuyu bölmek istemem ama Sn. Zeki Bey kodları açıklarsa çok memnun olacağım. Daha önce hiç karşılaşmadığım kodlar mevcut ve gerçekten çok hızlı çalışıyor. Örneğin Value2 nedir? Value ile Value2 farkı nedir? CreateObject("ADODB.Recordset") bu hangi işlemi gerçekleştiriyor? Hangi durumlarda bu ifade kullanılır?

 

[Zeki Gürsoy]

Merhaba,

EA-EZ aralığındaki tekrarlama sayılarını kontrol edin. Mevcut prosedure 2-3 ilave ve bir de performans iyileştirmesi ekledim (i7 makinede işlem süresi 0,8 sn).

Dosya ektedir.
.
.
.

Sub Baran_Listele()
    Dim rs As Object, son As Long, arr(1 To 5) As Variant, b As Integer, c As Long
    Dim t1 As Single, t2 As Single, d As Integer
    
    Sayfa2.[k1:l1].ClearContents
    
    Sayfa2.[k1] = Now
    
    t1 = Timer
    
    Sayfa2.Range("B2:F21").ClearComments
    Sayfa2.Range("B2:F21").ClearContents
    
    son = Sayfa1.[I100000].End(3).Row
    
    'İyi performans için belleğe al
    arr(1) = Sayfa1.Range("I8:I" & son).Value2
    arr(2) = Sayfa1.Range("M8:M" & son).Value2
    arr(3) = Sayfa1.Range("N8:N" & son).Value2
    arr(4) = Sayfa1.Range("Q8:Q" & son).Value2
    arr(5) = Sayfa1.Range("EA8:EZ" & son).Value2

    For b = 1 To 5
        
        Set rs = CreateObject("ADODB.Recordset")
        
        rs.Fields.Append "Ad", 200, 100 'varchar(100)
        rs.Fields.Append "Sıklık", 3 '32 bit integer
        
        rs.Open , , 0, 3 'forward,optimistic
        
        rs("Ad").Properties("Optimize") = True '~~ %50 performans(index oluşturur)
        
        For c = 1 To UBound(arr(b), 1)
        
            If Trim(arr(b)(c, 1)) <> "" Then 'Aralarda boş hücreler var
            
                
                If b < 5 Then
                
                      rs.Filter = "Ad = '" & arr(b)(c, 1) & "'"
    
                      If rs.RecordCount = 0 Then
                          rs.AddNew Array("Ad", "Sıklık"), Array(arr(b)(c, 1), 1)
                      Else
                          rs.Fields("Sıklık") = rs.Fields("Sıklık") + 1
                      End If
                
                Else
                
                    For d = 1 To UBound(arr(b), 2)
                        
                        If Trim(arr(b)(c, 1)) <> "" Then
                            
                            If Trim(arr(b)(c, d)) = "" Then Exit For
                            
                            rs.Filter = "Ad = '" & arr(b)(c, d) & "'"
                            
                            If rs.RecordCount = 0 Then
                                rs.AddNew Array("Ad", "Sıklık"), Array(arr(b)(c, d), 1)
                            Else
                                rs.Fields("Sıklık") = rs.Fields("Sıklık") + 1
                            End If
                        
                        End If
                        
                    Next
                    
                End If
                
            End If
            
        Next
        
        rs.Filter = 0 'Filitre deaktif
        
        rs.Sort = "[Sıklık] Desc" 'Azalan sıralama

        rs.MoveFirst 'İlk kayda git
        
        For c = 1 To Sayfa1.[n4] 'Ham sayfasının N4 hücresindeki sayı kadar.
            Sayfa2.Cells(c + 1, b + 1) = rs.Fields("Ad")
            Sayfa2.Cells(c + 1, b + 1).AddComment _
                "::..www.excel.web.tr..::" & vbCr & String(30, "-") & _
                vbCr & """" & rs("Ad") & """  " & rs("Sıklık") & " defa tekrarlandı."
            rs.MoveNext
            If rs.EOF Then Exit For '20 kayıt yoksa döngüden çık
        Next
        
    Next
    
    t2 = Timer
    
    Sayfa2.[l1] = t2 - t1 & " saniye"
End Sub

 

[Muhammet Okumuş]

Application.ScreenUpdating = False
yapınca 0,7 saniye sürüyor.

 

[Ömer BARAN]

Elinize sağlık Sayın GÜRSOY, çok teşekkür ederim.
Daha önce söylediğim gibi emanet bilgisayarda kontrol edebiliyorum.
8-10 kere çalıştırdım, şu anda işlem süresi 5 saniyeyi hiç bulmadı, genellikle 4-5 saniye arasında sürüyor. Bir önceki kod ise 3 saniye civarında sürüyr idi.
Makinem, Intel Core2 2.6 GHz 3 GB RAM 32 Bit.

Kodun başına Dim satırlarından sonra "Application.Calculation = xlCalculationManual" ve End'den önce de "Application.Calculation = xlCalculationAutomatic" ekleyerek çalıştırıyorum.
Çünkü sitede açtığım diğer bir konudaki ( ..::.. Formüller Yerine Makro Kodu ..::..) sıkıntıdan dolayı (yoğun DİZİ formülü sıkıntısı) mecburen böyle yapıyorum, henüz o soruna bir çözüm gelmedi.

 

[Ömer BARAN]

Application.Calculation = xlCalculationManual 'in yanısıra,
Application.ScreenUpdating = False ekleyince bendeki süre, 2-3,5 saniye geriledi.

 

[Zeki Gürsoy]

... Örneğin Value2 nedir? Value ile Value2 farkı nedir? CreateObject("ADODB.Recordset") bu hangi işlemi gerçekleştiriyor? Hangi durumlarda bu ifade kullanılır?

Value, tip dönüşümlü, value2 ise ham veri olarak getirir. Bu farkı boş bir dosyada A1 hücresine =bugün() formülü verin ve aşağıdaki prosedur sonucuna bakın. Value2 ile veriler belleğe daha hızlı yüklenir.(Dikkat; Tarihler sayı olarak gelir)

Sub test()
    Debug.Print [a1].Text
    Debug.Print [a1].Value
    Debug.Print [a1].Value2
End Sub

İki boyutlu dizilerde find,filter,sort gibi işlemleri karmaşık kod yazmadan, geçici sayfalar ekleyip silmeden kolay işlem yapabilmek için bellekte recordset oluşturup içini dolduruyoruz.

Kolay gelsin.


Sayın omer.baran, İdris beyin önerdiği gibi ham veri sayfasındaki verilieri veritabanı tablosu gibi kullanmanız mümkün değil mi? Excelin özet tablo özelliği ile sonuçları hem hızlı, hem de kolay alabilirsiniz.

 

[Muhammet Okumuş]

Sn Zeki Bey cevabınız için teşekkür ederim. Bizler daha yolun başındayız, almamız gereken çok yol var.

 

[Ömer BARAN]

Teşekkürler. KONU ÇÖZÜLMÜŞTÜR.

Konu ÇÖZÜLMÜŞTÜR.
Sayın Zeki GÜRSOY'a çok teşekkürler.

Bir de http://www.excel.web.tr/f48/oklu-suzden-kalan-benzersiz-veri-sayysy-ktf-t145889.html#post792487

konusuna çözüm üretilmesi kaldı.
Hayırlısı bakalım.

 

[Korhan Ayhan]

Konuyu kapatmışsınız ama ben bir örnek dosya daha hazırlamıştım. Boşa gitmesin.

İnceleyiniz.


Not : Özellikle veri sayısını 500.000 farklı ya da daha fazla veri üzerinde deneyip hızı test ediniz.

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")
                S2.Cells(Z, X + 2).ClearContents
            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]

Sayın AYHAN teşekkürler, şu an bilgisayarda değilim, test etme şansım ancak yarın olur, sizin elinizden çıktığına göre mutlaka iyi birçalışma olduğuna eminim. Test edince buraya yazarım. Aslında bana lazım olan kısmı Sayın GÜRSOY tamamladı, arşivlik olacağından emin olduğum sizin dosyanızı da saklayacağım.
İlgi vd destek için teşekkürler.

Keşke konu kapanış mesajımda belirttiğim diğer konuya da bakabilseniz
(http://www.excel.web.tr/f48/oklu-suz...tml#post792487)
sanırım asıl sıkıntıyı orada yaşayacağım.

Sayın GİZLEN'in kodunda müdahaleye ihtiyaç var.

Sağlıcakla.

 

[Ömer BARAN]

Konuyu kapatmışsınız ama ben bir örnek dosya daha hazırlamıştım. Boşa gitmesin.

İnceleyiniz.


Not : Özellikle veri sayısını 500.000 farklı ya da daha fazla veri üzerinde deneyip hızı test ediniz.

Sayın AYHAN çok teşekkür ederim.
Kodlar ÇOK ÇOK HIZLI ancak;

Sayın GÜRSOY'un yazdığı ilk kodda hatalı sonuç üreten kısım malesef sizin gönderdiğiniz dosyadaki kodda da geçerli.

Durum şöyle; EA-EZ arasındaki değerleri sayarken
(ve dolayısıyla sıklık sırasına koyarken ve sıklık değerini hücre açıklamasına yazarken)
sadece EA sütununu dikkate alıyor, yani EB'den itibaren EZ'ye kadarki değerler hiç yokmuş gibi işlem yapıyor.

Sayın GÜRSOY'a da bunu söylemiştim ve kendisi 1. kodda değişiklik yaparak 2'nci kodu göndermiş ve durumu düzeltmişti.

Sanırım sizin kodda da aynı düzeltmeye ihtiyaç var.
EA'dan sonraki sütunlardaki verileri silip kodu çalıştırdığımda sonuç aynı çıkıyor. Yani bu sütunlar dikkate alınmamış oluyor.

Tabi şu anki önceliğim ve aciliyetim,
..::.. Çoklu Süz'den Kalan Benzersiz Veri Sayısı KTF ..::..
konusunun çözülmesi.
Şayet çok sıkıntı vermeyeceksem ona bakmanız mümkün olur mu acaba?

 

[Korhan Ayhan]

Gerekli düzeltmeyi yaptım. Deneyebilirsiniz.

 

[Ömer BARAN]

Yok böyle bir şey, timer'a filan gerek yok, ölçmeye gerek yok. :bravo: :bravo: :keyif: :keyif:

Açtığım bir konuyu, hiç bu kadar keyifle kapatmamıştım.




Kapatmıyorum.

 

[Zeki Gürsoy]

Bu başlığı takip edenler de epeyi keyif almış. An itibariyle 1168 görüntüleme.

 

[Muhammet Okumuş]

Valla ben de şaştım bu işe. Acaba ben ne zaman bu kodları anlayabileceğim? Araştırıyorum ama daha kaynak bulamadım.

 

[Ömer BARAN]

Böyle yorumlar geleceğini tahmin ettiğimden konuyu kapatmamıştım.

 

[Muhammet Okumuş]

Bu seviyeye gelmek, bu şekil düşünebilmek için nasıl bir yöntem uygulamalıyız? Tavsiyeniz nedir?

 

[Korhan Ayhan]

Muhammet Bey,

Ben sürekli en iyiyi aramaya çalışıyorum. Bu da gelişmeme büyük ölçüde fayda sağlıyor. Birde kişisel yapımdan dolayı imkânsızı zorlamayı seviyorum.

İlk başlarda yazdığım makrolara baktığımda şimdi gülüyorum. Ben neler yazmışım diyerek...

Zaman ayırırsanız üstesinden gelemeyeceğiniz iş yoktur.