• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

vba da dizi fonksiyonu ile benzersiz liste ve toplam alma

Ş

şehiriçi

Katılım
1 Ağustos 2013
Mesajlar
563
Excel Vers. ve Dili
Ofis 2016 TR 32 Bit
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
 

Ekli dosyalar

Aşağıdaki haliyle hızlanacaktır.
C++: 
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
 
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 .
 

Ekli dosyalar

Cevap 1:
C++: 
Ü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.)
C++: 
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.
 
Ö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 ..
 

Ekli dosyalar

Şu kodu kullanın
C++: 
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
 
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.
 
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.

C++: 
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
 
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.
 
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
 

Ekli dosyalar

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.
230747
 
ö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
 
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.
 
Ö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
 
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.
 

Ekli dosyalar

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.
 
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
 

Ekli dosyalar

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


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.

C++: 
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
 
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 .
 

Ekli dosyalar

Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst