Makro-VBA ile Eğersay Formülü

[ilhanaraz]

Merhaba Arkadaşlar,

Makro-VBA ile Eğersay formulü belkide çok basit bir kod ama ben tıkandım, işin içinden çıkamadım
Bildiğiniz gibi ilk satıra Eğersay formülü yazılıp aşağı doğru kaydırdığımızda sayılacak veri 10000 satırların üzerine çıktığında formulü yazması ve formül varken filtreleri değiştirmek zaman alıyor. Hele benim gibi 100 binlerce hatta milyona varan satır ile çalışıyorsanız formulü yaz 2 saat bilgisayarın yüzüne bakma
Acemice bir makro yapmaya çalıştım olmadı.
İstediğim makro şöyle:

Eğer aktif hücrenin 1 sol hücresi dolu ise (duracağı yeri bilmesi için)
Bu hücredeki veriyi aynı sütununda kaç adet olduğunu say (Eğersay) "direk değeri yazacak"
Aktif hücrenin bir altına geçerek döngüye gir.

Yukarıda yazdığım gibi döngü en az 500 bin satıra gitmesi gerekiyor.

Değerli cevaplarınız için şimdiden teşekkür ederim.

 

[Korhan Ayhan]

Merhaba,

Bu kadar çok satır için döngüde zaman alacaktır.

Dosyanızın küçültülmüş bir örneğini paylaşıp yapmak istediğiniz işlemi açıklarsanız destek almanız kolaylaşır.

 

[ilhanaraz]

Örnek bir dosya yaptım ama forma dosya yüklemeyi bulamadım. Linkten indirebilirsiniz.

https://www.dosya.tc/server33/pmnona/Egersay_Makro.xlsm.html

 

[Korhan Ayhan]

Alan seçip kodu çalıştırın. Yanındaki sütuna sayma değerleri listelenecektir.

Örnek dosyanıza göre A1:A5000 seçip kodu çalıştırın. Sonuçlar B1:B5000 olarak listelenecektir.

Option Explicit

Sub Egersay()
    Dim Dizi As Object, Veri As Variant, X As Long, Say As Long, Zaman As Double
    
    Zaman = Timer
    
    Set Dizi = CreateObject("Scripting.Dictionary")
    
    Veri = Selection.Value
    
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        If Not Dizi.Exists(Veri(X, 1)) Then
            Dizi.Add Veri(X, 1), 1
        Else
            Dizi.Item(Veri(X, 1)) = Dizi.Item(Veri(X, 1)) + 1
        End If
    Next

    ReDim Liste(1 To UBound(Veri, 1), 1 To 1)
    
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        If Dizi.Exists(Veri(X, 1)) Then
            Say = Say + 1
            Liste(Say, 1) = Dizi.Item(Veri(X, 1))
        End If
    Next
    
    Selection.Cells(1, 2).Resize(UBound(Veri, 1)) = Liste
    
    MsgBox "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
End Sub

 

[ilhanaraz]

Harika
Bu kadar uzun bir kod olacağını düşünmemiştim elinize emeğinize sağlık çok teşekkür ederim.
1 milyon satırda denedim 7 saniyede işlem tamam. Formül il yaptığımda 8 çekirdek işlemci 3 dk da %1 işlem yapıyordu
Hızı da mükemmel çok teşekkürler çok işime yarayacak.