vba da dizi fonksiyonu ile benzersiz liste ve toplam alma

[Korhan Ayhan]

Bu şekilde deneyiniz.

Küsüratlı sayılarda yuvarlama yapmak sorunu çözebilir.

Option Explicit

Sub ToplamAl()
    Dim Veri As Variant, X As Long, Say As Long, Son As Long

    Son = Sheets("sayfa1").Cells(Rows.Count, 1).End(3).Row
    If Son < 3 Then Son = 3
    
    Veri = Range("A2:B" & Son).Value2
    
    ListBox1.Clear
    
    ReDim Liste(1 To 2, 1 To 1)
    
    With VBA.CreateObject("Scripting.Dictionary")
        For X = LBound(Veri, 1) To UBound(Veri, 1)
            If Not .Exists(Veri(X, 1)) Then
                Say = Say + 1
                .Add Veri(X, 1), Say
                ReDim Preserve Liste(1 To 2, 1 To Say)
                Liste(1, Say) = Veri(X, 1)
                Liste(2, Say) = VBA.Format(VBA.Round(Veri(X, 2), 2), "#,##0.00")
            Else
                Liste(2, .Item(Veri(X, 1))) = VBA.Format(VBA.Round(Liste(2, .Item(Veri(X, 1))) + Veri(X, 2), 2), "#,##0.00")
            End If
        Next
    End With
    
    ListBox1.ColumnCount = 2
    ListBox1.Column = Liste
End Sub

 

[Korhan Ayhan]

Bu da #5 nolu mesajınızda ki sorunuzun cevabıdır.

Option Explicit

Sub Summary()
    Dim My_Data As Variant, Last_Row As Long, X As Long
    Dim Record_Count As Long, Process_Time As Double
    
    Process_Time = Timer
    
    Range("C2:C" & Rows.Count).ClearContents
    
    Last_Row = Cells(Rows.Count, 1).End(3).Row
    If Last_Row < 3 Then Last_Row = 3
    
    My_Data = Range("A2:B" & Last_Row).Value2
    
    ReDim Sum_List(1 To Rows.Count, 1 To 1)
    
    With VBA.CreateObject("Scripting.Dictionary")
        For X = LBound(My_Data, 1) To UBound(My_Data, 1)
            If Not .Exists(My_Data(X, 1)) Then
                Record_Count = Record_Count + 1
                .Add My_Data(X, 1), Record_Count
                Sum_List(Record_Count, 1) = My_Data(X, 2)
            Else
                Sum_List(.Item(My_Data(X, 1)), 1) = Sum_List(.Item(My_Data(X, 1)), 1) + My_Data(X, 2)
            End If
        Next
        
        ReDim My_List(1 To Rows.Count, 1 To 1)
        
        For X = LBound(My_Data, 1) To UBound(My_Data, 1)
            My_List(X, 1) = Sum_List(.Item(My_Data(X, 1)), 1)
        Next
        
        Range("C2").Resize(UBound(My_Data, 1)) = My_List
    End With
    
    Erase My_Data
    Erase Sum_List
    Erase My_List
    
    MsgBox "İşlem süresi ; " & Format(Timer - Process_Time, "0.00") & " Saniye"
End Sub

 

[şehiriçi]

Korhan moderatörüm ,Emeğinize sağlık , çok teşekkürler
listbox düzeldi istediğim gibi oldu .5 nolu mesaj daki sorumun cevabı alındı ve kod çok hızlı çalıştı .
Ancak sorumun cevabını vermiş olmanıza rağmen (kayan noktalı...) bir nevi tekrar gibi olacak ama 18 nolu mesajımdaki bu şu kısmı tekrar kopyalayıp gönderiyorum

sarı renkle işaretlediğim hücreler örneğin C3 seçildiğinde formül çubuğuna baktığınızda 1,81898940354586E-12 rakamı görünüyor . ama C3 hücresine bakınca 0,000 görünüyor . Ama gerçekte örneğin mustafa ların C sütunundaki verilerini toplayınca 0,000 olması doğru sonuç niye formül çubuğunda rakam geliyor sonucu ilerde yanlış yapmaz mı
formül çubuğunda da 0,000 görünme ihtimali yokmu , ya da sakıncası yoksa teşekkür edip bu konuyu kapatacağım , teşekkürler

 

[Korhan Ayhan]

Excel ondalıklı sayırlarda bu sapmayı bünyesinde barındırıyor. Bu sebeple YUVARLAMA fonksiyonlarının kullanılmasını tavsiye ediyorlar.

Sizin sorun oluşturur dediğiniz küsürattaki rakamlar ekteki dosyada göreceğiniz üzere 12. karakterde başlıyor. Bu sebeple çok büyük sıkıntılara yol açacağını düşünmüyorum.

Ek olarak önerdiğim makroya ROUND (YUVARLA) özelliğini ekledim. Butona tekrar tıkladığınızda o gördüğünüz küsüratların yok olduğunu görebilirsiniz.

Yine konuyla ilişkili olduğunu düşündüğüm linki inceleyiniz.

toplamada kuruş farkı

23,45 dağıtılacak para bu paranın %35'ini 3 kişiye bu paranın %57'sini 4 kişiye bu paranın %2'sini 1 kişiye bu paranın %6'sını 1 kişiye dağıttığım zaman 23,43 tutuyor. Burada 2 krş eksik çıkıyor. bu tutarı dağtılacak para ile dağıtılanı eşit çıkaramıyorum. yardımcı olabilir misiniz?

www.excel.web.tr

 

[şehiriçi]

Korhan bey sorunum da bitmiyor ki , mümkünse bir ricam daha olacak ,
listboxta 2 sütunda ki veri eğer sıfır ise (0,000) görünmesin bana sadece sıfırdan farklı olanlar lazım .sıfır olanlar alacak_borcu olmayanlar oysa bana sadece alacak borç kısmı lazım .yani sıfırdan farklı olanlar

 

[Korhan Ayhan]

Profilinizde yazan excel sürüm bilgisi yeterli değildir. Güncellemenizi rica ederim. Bizim profilimizde yazanları örnek alabilirsiniz.

Excel Vers. ve Dili 2003

 

[şehiriçi]

Korhan bey excel vers 2016 kullandığım bilgisayarda ayrıca güncellemeyi nasıl yapıyoruz

 

[Korhan Ayhan]

#24 nolu mesajımda ki dosyayı son talebinize göre revize ettim. İndirip deneyebilirsiniz.

 

[şehiriçi]

Korhan bey , excel sürüm bilgimi güncelledim kod larda istediğim gibi oldu ,teşekkürler, iyi ki varsınız sağlıkla kalın ..

 

[Korhan Ayhan]

Sürüm bilgisi eksik olmuş. Bizlerin profiline bakarak güncellerseniz daha faydalı olacaktır. Bu bilgiler size verilen cevaplar için önem arz etmektedir.

Ofisin Yıl Bilgisi
Ofisin Dil Bilgisi
Ofisin Bit Bilgisi

Mesela ben sizin gibi profil bilgisi olan bir üyeye İNGİLİZCE formül önerir geçerim.

 

[şehiriçi]

VBA.CreateObject("Scripting.Dictionary") bu nesneyi anlayacağımız şekilde anlatan bir youtube kanalı veya site varmı? anlamakta çok zorlanıyorum dahası anlıyamıyorum ,okumak değilde birisi anlatınca kavrayacağımı umuyorum , Teşekkürler

 

[ÖmerFaruk]

https://www.youtube.com/results?search_query=Scripting.Dictionary

 

[Korhan Ayhan]

Bence en önce temel vba bilgilerini öğrenmenizde fayda var. Sonrası zaten ihtiyaca göre şekillenecektir.

 

[şehiriçi]

Ömer hocam bende ingilizce yok ..türkçe kaynak yok mu?
Korhan hocam temel vba bilgileri derken az açıklık getirsen....

 

[Korhan Ayhan]

Siz önce #30 nolu mesajıma uygun şekilde ofis sürümünü güncelleyiniz.

Örnek;

 

[şehiriçi]

Korhan Bey güncelledim.

 

[Korhan Ayhan]

Ömer hocam bende ingilizce yok ..türkçe kaynak yok mu?
Korhan hocam temel vba bilgileri derken az açıklık getirsen....

Dictionary nesnesine gelmeden önce bence öğrenmeniz gereken daha başka konuların olduğunu düşünüyorum.

Aşağıdaki konular hakkında temel bilginiz var mı?

VBA- Sayfa Olayları
VBA- Çalışma Kitabı Olayları
VBA- Modüle Ekleme - Makro Oluşturma - Makro Kaydet Yöntemi
VBA- Döngüler (For-Next / Do-While-Loop / While-Wend)
VBA- If-End If Sorgu Teknikleri
VBA- Select Case-End Select Sorgu Teknikleri

Bu temel teknikleri öğrenmeden üst seviye diyebileceğimiz Dictionary nesnesini öğrenmeye çalışmak çok akıllıca olmayacaktır.