vba da dizi fonksiyonu ile benzersiz liste ve toplam alma

[şehiriçi]

Merhaba ,
Arkadaşlar ekteki dosyamda dizi fonksiyonu ile benzersiz şekilde A sütunundaki verileri C sütununa , ve D sütunu na da toplamlarını aldırdım.
Ancak kod çok yavaş çalışıyor daha hızlı çalışması için desteğinize ihtiyacım var , emek veren tüm Arkadaşlarıma şimdiden teşekkürler

 

[ÖmerFaruk]

Aşağıdaki haliyle hızlanacaktır.

Sub TOPLAM_AL()
Dim Veri As Variant, i As Long, say As Long, Son As Long
    Application.ScreenUpdating = False 'Ekran hareketlerini gösterme
    Application.Calculation = xlCalculationManual 'Formül hesaplamalarını "EL İLE" yap

    Son = Sheets("sayfa1").Cells(Rows.Count, 1).End(3).Row
    If Son < 2 Then Son = 2
    Veri = Range("A2:B" & Son)
    Range("C2:D" & Son).Clear
    ReDim Liste(1 To UBound(Veri, 1), 1 To 2)
    With VBA.CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(Veri, 1)
        If Not .Exists(Veri(i, 1)) Then
            say = say + 1
            .Add Veri(i, 1), say
            Liste(say, 1) = Veri(i, 1)
            Liste(say, 2) = Veri(i, 2)
        Else
            Liste(.Item(Veri(i, 1)), 2) = Liste(.Item(Veri(i, 1)), 2) + Veri(i, 2)
        End If
    Next
    End With
    Range("C2").Resize(say, 2) = Liste
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    MsgBox "Hesaplama tamamlanmıştır.", vbInformation
End Sub

 

[şehiriçi]

Selam ,
Ömer Faruk Hocam elinize emeğinize sağlık çok teşekkürler ,mükemmel ,hızı arttı .
Hocam mümkünse sizden 3 talebim olacak
1 . Aynı dosyanın A sütununda ki isimlerin C sütununda ki karşısına genel toplamını yazdırmak , çünki benim gerçek dosyamda öyle yapmak istiyorum 2. Yukarıda verdiğiniz kodu userformda listboxta görmek istiyorum
3 . ise bu CreateObject("Scripting.Dictionary") nesnesini ben öğrenmek istiyorum, bu nesneyi anlatan bir video önerebilir misin veya var mı? bir çok sitede metin şeklinde var ama ben anlamakta çok zorlanıyorum .
dosyayı verdiğiniz koda göre değiştirdim . istediğim genel toplamıda manuel olarak ilk 18 satırda gösterdim .

 

[ÖmerFaruk]

Cevap 1:

Üstteki satırları bulun alttakilerle değiştirin
'Veri = Range("A2:B" & Son)
Veri = Range("A2:C" & Son)

'Liste(say, 2) = Veri(i, 2)
Liste(say, 2) = Veri(i, 3)

'Liste(.Item(Veri(i, 1)), 2) = Liste(.Item(Veri(i, 1)), 2) + Veri(i, 2)
Liste(.Item(Veri(i, 1)), 2) = Liste(.Item(Veri(i, 1)), 2) + Veri(i, 3)

Cevap 2:
Listbox olan Userformda aşağıdaki kodları kullanabilirsiniz.
(A-B sütunlarına göre. Arzu ederseniz Cevap 1 den faydalanarak A-C sütunlarına göre işlem yapabilirsiniz.)

Sub ToplamAl()
Dim Veri As Variant, i As Long, say As Long, Son As Long

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

Private Sub UserForm_Initialize()
Call Me.ToplamAl
End Sub

Cevap3:
a. Excel.Web.Tr / Arama Menüsüne Scripting + Dictionary yazın.
b. Google Arama çubuğuna Scripting.Dictionary Excel VBA yazın.

 

[şehiriçi]

ÖmerFaruk bey , çok teşekkürler emeğinize sağlık
1 . sorumu galiba tam izah edemedim , şöyleki benim istediğim A sütunundaki verinin örneğin ali nin B sütunundaki toplamlarını alıp , yine A sütunundaki her bir ali nin C sütunundaki karşısına yazdırmak ...Bunu manuel olarak ilk 18 satıra yazdım ..Diğer 2 sorumun cevabını aldım.Desteğiniz için çok teşekkürler ..

 

[ÖmerFaruk]

Şu kodu kullanın

Sub TOPLAM_AL()
Dim Son As Long
    Son = Sheets("sayfa1").Cells(Rows.Count, 1).End(3).Row
    If Son < 2 Then Son = 2
    With Sheets("Sayfa1").Range("C2:C" & Son)
        .Formula = "=SUMIF(Sayfa1!$A:$A,Sayfa1!$A2,Sayfa1!$B:$B)"
        .Value = .Value
        .NumberFormat = "#,##0,000"
    End With
    MsgBox "Hesaplama tamamlanmıştır.", vbInformation
End Sub

 

[şehiriçi]

Hocam kod cevap veriyor ama bekleme fazla CreateObject("Scripting.Dictionary") la hızlı hesaplama yapılamazmı sizi de uğraştırıyorum ama hakkınızı helal edin , hem bende bu arada CreateObject("Scripting.Dictionary") nesnesini anlamaya çalışıyorum .saygılarımla.

 

[ÖmerFaruk]

Kodlara süreyi de ekledim. Dosyanızda 10.042 işlem yapılacak satır var. Kodun bendeki süresi 0,36 sn.
Bilgisayarınız yavaş dahi olsa 1 saniye süreceğini tahmin etmiyorum.
Eğer yavaşsa dosyanızı kapatın, exeli kapatın. Sadece dosyanızı açarak deneyin. Ve eğer dosyanızda farklı kodlar da varsa onlardan da kaynaklanabilen bir yavaşlık olabilir.

Sub TOPLAM_AL()
Dim Son As Long, Zaman As Double
    Zaman = Timer
    Son = Sheets("sayfa1").Cells(Rows.Count, 1).End(3).Row
    If Son < 2 Then Son = 2
    With Sheets("Sayfa1").Range("C2:C" & Son)
        .Formula = "=SUMIF(Sayfa1!$A:$A,Sayfa1!$A2,Sayfa1!$B:$B)"
        .Value = .Value
        .NumberFormat = "#,##0,000"
    End With
    MsgBox "Hesaplama tamamlanmıştır." & vbCr & vbCr & "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " saniye", vbInformation
End Sub

 

[şehiriçi]

Tüm dosyaları kapattım artı bilgisayarıda kapattım açtım sadece size örnek olarak gönderdiğim dosyayı açıp denedim . işlem süresi ; 8,57 saniye yazıyor.

 

[şehiriçi]

Application.ScreenUpdating = False 'Ekran hareketlerini gösterme
Application.Calculation = xlCalculationManual 'Formül hesaplamalarını "EL

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

yukardaki kodu ilave edince süre daha da uzadı 32,48 saniye , ? anlamıyorum daha da kısalması gerekmezmiydi

 

[ÖmerFaruk]

Gönderdiğiniz dosyada ( daha önceki mesajda) sayfa ya da satır eksiltmeden aldığım sonuç aşağıda. Ayrıca önümde 7 adet excel dosyası da açık vaziyette.

 

[şehiriçi]

ömer bey son mesajınızı (11.mesaj) nasıl excelden resim edip gönderiyorsunuz ben de kendi excel bilgisayarımda ki excel dosyasını göndermek istiyorum

 

[ÖmerFaruk]

Ekran alıntı çalıştırıyorum / Düzen / Kopyala ...bu mesaj yazdığım alana yapıştır diyorum
Ancak sizin bunu yapmanıza gerek yok.

Eğer bana #5 nolu mesajda gödnerdiğiniz dosyada olduğu gibi excel dosyanızda başka veri başka kod yoksa, ya exceli kaldırıp tekrar yüklemeli ya da bilgisayarı değiştirmelisiniz.

 

[şehiriçi]

Ömer hocam dediğiniz gibi herhalde benim bilgisayarda bir şey var , hayırlısı ,desteğiniz için teşekküler .
Son kez 13 mesajınızda ki ...Ekran alıntı çalıştırıyorum / Düzen / Kopyala ....Ekran alıntı nasıl çalıştırılır varsa bu sitede bir açıklması veya siz tarif ederseniz ilerde ben de kullanmak istiyorum . İyi akşamlar

 

[ÖmerFaruk]

 

[şehiriçi]

Değerli forum üyeleri tekrar Merhaba ,
Ömer bey , e_toplam almada bir yanlışlık olduğunu farkettim ,mümkünse bir bakabilirmi siniz?
dosyanın son güncel halini ekte gönderiyorum . örneğin C2 hücresi ...hatalı Csütunlarını renklendirdim , saygılarımla.

 

[Korhan Ayhan]

Paylaştığınız dosyanızda sarı renkle belirttiğiniz isimleri süzüp toplamını aldığınızda SIFIR çıkıyor. Yani makroda sorun yok gibi görünüyor.

 

[şehiriçi]

Korhan bey merhaba ,
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ı ?
ayrıca ...listboxta göster... butonuna bastığınız zaman örneğin mustafa nın toplam sıfır olması gerekirken mustafa -1 görünüyor işte sonuç yanlış..
ama bu sorunu sizin çözeceğinizden Allah ın izniyle çok eminim, teşekkürler

 

[Korhan Ayhan]

Küsürat bölümünü arttırdığınızda o rakamları görebilirsiniz. Konuyla ilgili linki inceleyebilirsiniz.

http://www.excelgurusu.com/excelde-kayan-nokta-hesaplamalari-ve-tutarsizlik/

Userform kodunuzda kullandığınız Format kullanımından kaynaklı sorun yaşıyorsunuz. Aşağıdaki gibi değiştirirseniz Listboxta veriler düzgün görünür.

Sub ToplamAl()
    Dim Veri As Variant, i As Long, say As Long, Son As Long

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

 

[şehiriçi]

Merhaba ,
Korhan bey formatı dediğiniz gibi değiştirdim , denemek için 89 ve 90 . satırlara mustafa adına ilave yaptım sonra tekrar listbox ta göster butonuna bastım yine mustafa hatalı 0,01 sonucunu döndürdü . Ayrıca verdiğiniz link için teşekkürler okuyup anlamaya çalışıyorum ,henüz tam kavrayabilmiş değilim ,anlamaya çalışıyorum ,ilginize teşekkürler .