[Yardım]  Koşula Göre Benzersiz Verileri Bul ve Topla

VBA Makrolar ile ilgili sormak istedikleriniz, yapmak istedikleriniz hakkında yardım alabileceğiniz bölümdür.

Koşula Göre Benzersiz Verileri Bul ve Topla

İleti#1)  turk-x » 26 Ağu 2019 22:59

Merhabalar;
8000 satırdan fazla veri içeren excel sayfamda belirli koşullara göre raporlama yapmaya çalışıyorum. Ama kodlarım çok yavaş çalıştığı için desteğinize ihtiyacım var. Örnek dosyada hızlı çalışıyor ama orjinal dosyada çok yavaş çalışıyor.

Özetle Yapmak istediğim Şey Şu:
Sorumlu = 01-Ahmet ve Durum=Aktif 'se Koşula uyan Proje Kodlarını Benzersiz Listele ve Proje Koduna göre tutarları topla

Kullandığım Kod
Kod: Tümünü seç
Sub Rapor()
Set K = Sheets("KAZANC")
Set V = Sheets("VERILER")
Set Sorumlu = K.Range("B3")
Set Durum = K.Range("C3")

K.Range("B6:F" & K.Cells(65536, 2).End(xlUp).Row + 1).ClearContents

For i = 14 To V.Cells(65536, 1).End(xlUp).Row

If V.Range("A" & i) = Sorumlu And V.Range("F" & i) = Durum Then

PKod = V.Range("B" & i).Value
Son = K.Cells(65536, "B").End(xlUp).Row + 1


If WorksheetFunction.CountIf(K.Range("B6:b" & Son), PKod) = 0 Then

K.Range("B" & Son) = PKod
K.Range("C" & Son) = V.Range("C" & i).Value
K.Range("D" & Son).FormulaR1C1 = _
"=SUMIFS(VERILER!R14C:R21243C,VERILER!R14C[-2]:R21243C[-2],KAZANC!RC[-2],VERILER!R14C[-3]:R21243C[-3],KAZANC!R3C[-2],VERILER!R14C[2]:R21243C[2],KAZANC!R3C[-1],VERILER!R14C[1]:R21243C[1],""A"")"
K.Range("E" & Son).FormulaR1C1 = _
"=SUMIFS(VERILER!R14C[-1]:R21243C[-1],VERILER!R14C[-3]:R21243C[-3],KAZANC!RC[-3],VERILER!R14C[-4]:R21243C[-4],KAZANC!R3C[-3],VERILER!R14C[1]:R21243C[1],KAZANC!R3C[-2],VERILER!R14C:R21243C,""S"")"
K.Range("F" & Son).FormulaR1C1 = "=RC[-1]-RC[-2]"

End If
End If

Next i

End Sub

Bu iletideki ekleri görmek için gerekli yetkilere sahip değilsiniz.
Kullanıcı avatarı
turk-x
 
Adı Soyadı:Ömer Hazır
Kayıt: 16 Oca 2009 16:08
Konum: Dünya
Meslek: Muhasebe
Yaş: 36
İleti: 4
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: Denizli

Cevap: Koşula Göre Benzersiz Verileri Bul ve Topla

İleti#2)  erseldemirel2 » 26 Ağu 2019 23:41

turk-x yazdı:Merhabalar;
8000 satırdan fazla veri içeren excel sayfamda belirli koşullara göre raporlama yapmaya çalışıyorum. Ama kodlarım çok yavaş çalıştığı için desteğinize ihtiyacım var. Örnek dosyada hızlı çalışıyor ama orjinal dosyada çok yavaş çalışıyor.

Özetle Yapmak istediğim Şey Şu:
Sorumlu = 01-Ahmet ve Durum=Aktif 'se Koşula uyan Proje Kodlarını Benzersiz Listele ve Proje Koduna göre tutarları topla

Kullandığım Kod
Kod: Tümünü seç
Sub Rapor()
Set K = Sheets("KAZANC")
Set V = Sheets("VERILER")
Set Sorumlu = K.Range("B3")
Set Durum = K.Range("C3")

K.Range("B6:F" & K.Cells(65536, 2).End(xlUp).Row + 1).ClearContents

For i = 14 To V.Cells(65536, 1).End(xlUp).Row

If V.Range("A" & i) = Sorumlu And V.Range("F" & i) = Durum Then

PKod = V.Range("B" & i).Value
Son = K.Cells(65536, "B").End(xlUp).Row + 1


If WorksheetFunction.CountIf(K.Range("B6:b" & Son), PKod) = 0 Then

K.Range("B" & Son) = PKod
K.Range("C" & Son) = V.Range("C" & i).Value
K.Range("D" & Son).FormulaR1C1 = _
"=SUMIFS(VERILER!R14C:R21243C,VERILER!R14C[-2]:R21243C[-2],KAZANC!RC[-2],VERILER!R14C[-3]:R21243C[-3],KAZANC!R3C[-2],VERILER!R14C[2]:R21243C[2],KAZANC!R3C[-1],VERILER!R14C[1]:R21243C[1],""A"")"
K.Range("E" & Son).FormulaR1C1 = _
"=SUMIFS(VERILER!R14C[-1]:R21243C[-1],VERILER!R14C[-3]:R21243C[-3],KAZANC!RC[-3],VERILER!R14C[-4]:R21243C[-4],KAZANC!R3C[-3],VERILER!R14C[1]:R21243C[1],KAZANC!R3C[-2],VERILER!R14C:R21243C,""S"")"
K.Range("F" & Son).FormulaR1C1 = "=RC[-1]-RC[-2]"

End If
End If

Next i

End Sub







Arka planda hücreler değişeceği için sürekli ekran yenilenmesi olur ve zaman alır bu. Makro yavaşlar.

Application.ScreenUpdating = False

Kullanın. Arka planda hücreler değişmesin. Makro nun başında false olsun sonunda true olsun. Öyle bir denermisiniz?
www.erseldemirel.com.tr
Kullanıcı avatarı
erseldemirel2
Siteye Alışmış
 
Kayıt: 31 Oca 2019 12:51
Meslek: işsiz
Yaş: 35
İleti: 236
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: Ankara / Çankaya

Cevap: Koşula Göre Benzersiz Verileri Bul ve Topla

İleti#3)  turk-x » 28 Ağu 2019 19:38

Merhaba erseldemirel2;
öncelikle zaman ayırdığınız için teşekkür ederim.
turk-x yazdı:Arka planda hücreler değişeceği için sürekli ekran yenilenmesi olur ve zaman alır bu. Makro yavaşlar.

Application.ScreenUpdating = False

Kullanın. Arka planda hücreler değişmesin. Makro nun başında false olsun sonunda true olsun. Öyle bir denermisiniz?


sorun ekran yenilemesi ve hücre değişimi ile ilgili bir durum değil.

Sorun yazdığım kodun mantığı ile ilgili daha hızlı çalışabilecek kod arıyorum.
Kullanıcı avatarı
turk-x
 
Adı Soyadı:Ömer Hazır
Kayıt: 16 Oca 2009 16:08
Konum: Dünya
Meslek: Muhasebe
Yaş: 36
İleti: 4
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: Denizli

Cevap: Cevap: Koşula Göre Benzersiz Verileri Bul ve Topla

İleti#4)  erseldemirel2 » 28 Ağu 2019 20:52

turk-x yazdı:Merhaba erseldemirel2;
öncelikle zaman ayırdığınız için teşekkür ederim.
turk-x yazdı:Arka planda hücreler değişeceği için sürekli ekran yenilenmesi olur ve zaman alır bu. Makro yavaşlar.

Application.ScreenUpdating = False

Kullanın. Arka planda hücreler değişmesin. Makro nun başında false olsun sonunda true olsun. Öyle bir denermisiniz?


sorun ekran yenilemesi ve hücre değişimi ile ilgili bir durum değil.

Sorun yazdığım kodun mantığı ile ilgili daha hızlı çalışabilecek kod arıyorum.



Çok veri olursa R1C1 ile yapılan sumifs fonksiyonu ağır kalabilir. bunun yerine diziler ile çalışmak gerekir. Böyle örnek dosya var. Excel 12 Mb büyük. Aşağıda indirme linki var. Kendi bilgisayarımdaydı. onu inceleyin. Örnek bir muavin defterden sumifs olarak verileri dizi olarak alıyor. sanırım hız probleminizi bu mantık çözer. Dosyayı bir inceleyin.


https://transfernow.net/321tg4a2qri0
www.erseldemirel.com.tr
Kullanıcı avatarı
erseldemirel2
Siteye Alışmış
 
Kayıt: 31 Oca 2019 12:51
Meslek: işsiz
Yaş: 35
İleti: 236
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: Ankara / Çankaya

REKLAM
Excel Logo XML Oluşturucu
Logo Object Designer ile Uyarlama

Cevap: Koşula Göre Benzersiz Verileri Bul ve Topla

İleti#5)  turk-x » 28 Ağu 2019 21:14

erseldemirel2 Bey;

Yavaş olan kısım benzersiz verilerin bulunduğu Proje Kodları kısmında yaklaşık 8 bin kayıt üzerinde karşılaştırma yapıyor.
Proje kodu bulunduktan sonra sum if sadece 30-40 veri üzerinde çalışıyor.

ama gönderdiğiniz dosya da dizilerle çalışma mantığını kendi çalışmama uyarlayabilirim diye düşünüyorum.
daha önce vba da CreateObject("Scripting.Dictionary") hiç kullanmamıştım.

desteğiniz için teşekkür ederim.
Kullanıcı avatarı
turk-x
 
Adı Soyadı:Ömer Hazır
Kayıt: 16 Oca 2009 16:08
Konum: Dünya
Meslek: Muhasebe
Yaş: 36
İleti: 4
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: Denizli

Cevap: Cevap: Koşula Göre Benzersiz Verileri Bul ve Topla

İleti#6)  erseldemirel2 » 28 Ağu 2019 21:18

turk-x yazdı:erseldemirel2 Bey;

Yavaş olan kısım benzersiz verilerin bulunduğu Proje Kodları kısmında yaklaşık 8 bin kayıt üzerinde karşılaştırma yapıyor.
Proje kodu bulunduktan sonra sum if sadece 30-40 veri üzerinde çalışıyor.

ama gönderdiğiniz dosya da dizilerle çalışma mantığını kendi çalışmama uyarlayabilirim diye düşünüyorum.
daha önce vba da CreateObject("Scripting.Dictionary") hiç kullanmamıştım.

desteğiniz için teşekkür ederim.



Sanırım 1 milyon satırlık veriden CreateObject("Scripting.Dictionary") ile sayı ve karakter karışık (S67TY4) gibi benzersiz atama yapıyor. Böylece oldukça fazla veri ile çalışılabiliyor. Umarım kendi kodlarınızı uyarlayabilirsiniz.
Başarılı olursanız paylaşmanızı umarım. Cidden güzel bir örnek olur. Kolay gelsin
www.erseldemirel.com.tr
Kullanıcı avatarı
erseldemirel2
Siteye Alışmış
 
Kayıt: 31 Oca 2019 12:51
Meslek: işsiz
Yaş: 35
İleti: 236
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: Ankara / Çankaya

REKLAM
ETA - Excel Konsolide Raporlama
ETA Excel Personel Entegre Raporu

Cevap: Koşula Göre Benzersiz Verileri Bul ve Topla

İleti#7)  turk-x » 31 Ağu 2019 23:17

Merhabalar.
Kendi Sorduğum Soruya kendim yanıt Vereyim:)
Bu Kod Çok kullanışlı ve Dictionary yöntemini kullanmak performans açısından çok iyi olduğu için kodu mümkün olduğunca açıklamalı olarak yazmaya çalıştım.
Ben işimi SQL sorgusu ile çözdüğüm için bu kodu kullanmak nasip olmadı. Ama kodu da yarım bırakmak içime sinmedi hem yöntemi öğrenmek için hemde birilerine faydası olur düşüncesiyle kodu tamamlayıp örnek dosyası ile birlikte ekliyorum. Umarım faydalanan birileri çıkar:)

Kod 65 bin kayıt üzerinden benzersiz Proje Koduna göre 4 farklı kritere göre verileri 1 saniye gibi bir sürede raporlama yapıyor.
(örnekteki dosyada veri sayısı dosya yükleme boyutu nedeniyle 40 bine düşürüldü)
Kod: Tümünü seç
Sub Raporla()
    Dim S As Object, Liste(), Dizi()
    Sheets(2).Select
    Son = Cells(Rows.Count, "B").End(3).Row + 1 ' Kazanç sayfasındaki Son Dolu hücre noyu son değerine atadık.
    Sheets(2).Range("B6:F" & Son).ClearContents ' Kazanç Sayfasındaki B6:B & Son aralığını temizledik.
    Son = Sheets(1).Cells(Rows.Count, "a").End(3).Row ' Veriler Sayfasındaki Son dolu hücre noyu son degerine atadık.
    Liste = Sheets(1).Range("a2:F" & Son).Value 'Veriler sayfasındaki a2:F & Son aralığını liste dizisi olarak tanımladık.

    ReDim Dizi(1 To Son, 1 To 1) 'Redim le dizi nin Boyutlarını tanımladık bu tanıma göre satır sayısı son değeri kadar sütun sayısı da 1
   
    Set S = CreateObject("Scripting.Dictionary") 'Dictionary S olarak tanımladık
        Sorumlu = [B3]
        Durum = [C3]
   
   'Verileri Liste Dizisinin içinde karşılaştırmak için for döngüsüne soktuk..
    For i = 1 To UBound(Liste, 1) ' UBound liste dizisinin 1 sütunundaki son verinin satır mumarasını verir.
        Aranan = Liste(i, 2) ' Liste Dizisinin 2 Sütununun i değeri
       
        'Sorumlu ve Durum Liste Dizisindeki değerlerle eşitse ve Aranan Değer Dictionary de yoksa ekleyelim
        'Bu sorguyla tekrarlanan proje kodlarını dictionarye eklenmesini önledik. Sadece 1 kez ekleyecek.
        If Sorumlu = Liste(i, 1) And Durum = Liste(i, 6) And Not S.exists(Aranan) Then
           Say = Say + 1 'Say değerini 1 artıralım
           S.Add Aranan, Say 'Dictionary ye aranan değeri ekleyelim.
            'Redim Preserve ile daha önce dizi ye eklediğimiz veriler silinmeden yeniden diziyi boyutlandıralım
            ReDim Preserve Dizi(1 To Son, 1 To 5) 'Diziyi Son sayısı kadar satır ve 5 sütun olarak yeniden boyutlandırdık.
            'Dizimizin 1. sutununun Say değerindeki satırına Listenin 2.Sütununun i satırındaki değeri ekledik.
            Dizi(Say, 1) = Liste(i, 2) 'Proje Kodumuzu Ekledik.
            'Dizimizin 2. sutununun Say değerindeki satırına Listenin 3.Sütununun i satırındaki değeri ekledik.
            Dizi(Say, 2) = Liste(i, 3) 'Proje Adı
        End If
'TOPLAMLARIN ALINDIĞI BÖLÜM.

        If Sorumlu = Liste(i, 1) And Durum = Liste(i, 6) Then 'Sorumlu ve Durum eşleşiyorsa
            If Liste(i, 5) = "A" Then Dizi(S.Item(Aranan), 3) = Dizi(S.Item(Aranan), 3) + Liste(i, 4) 'Alışları Dizinin 2. Satırında topla
            If Liste(i, 5) = "S" Then Dizi(S.Item(Aranan), 4) = Dizi(S.Item(Aranan), 4) + Liste(i, 4) 'Satışları Dizinin 3. Satırında topla
            Dizi(S.Item(Aranan), 5) = Dizi(S.Item(Aranan), 4) - Dizi(S.Item(Aranan), 3) ' Dizideki 3. Satırı 2. satırdan çıkar.
        End If
    Next i
   
    Sheets(2).Range("B6").Resize(S.Count, 5) = Dizi 'Diziyi Kazanç Sayfasında B6 hücresinden itibaren yaz.

End Sub
Bu iletideki ekleri görmek için gerekli yetkilere sahip değilsiniz.
Kullanıcı avatarı
turk-x
 
Adı Soyadı:Ömer Hazır
Kayıt: 16 Oca 2009 16:08
Konum: Dünya
Meslek: Muhasebe
Yaş: 36
İleti: 4
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: Denizli

Cevap: Cevap: Koşula Göre Benzersiz Verileri Bul ve Topla

İleti#8)  erseldemirel2 » 11 Eyl 2019 22:42

Örnek için teşekkürler çok faydalı oldu herkes için. Kolay gelsin
www.erseldemirel.com.tr
Kullanıcı avatarı
erseldemirel2
Siteye Alışmış
 
Kayıt: 31 Oca 2019 12:51
Meslek: işsiz
Yaş: 35
İleti: 236
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: Ankara / Çankaya

Cevap: Koşula Göre Benzersiz Verileri Bul ve Topla

İleti#9)  Vedat ÖZER » 12 Eyl 2019 08:31

Merhaba,

Çözümünüz için teşekkür ederim.
Ado ile çözümünü ekliyorum.

Kod: Tümünü seç
Sub TOPLA()
   
    Dim son_satir&
    Zaman = Timer
    With Application
    .ScreenUpdating = False
    End With

    Set con = VBA.CreateObject("adodb.Connection")
    Set rs = VBA.CreateObject("adodb.Recordset")
    con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
    ThisWorkbook.FullName & ";extended properties=""Excel 12.0;hdr=no"""
    Range("h6:L" & Rows.Count).ClearContents
    son_satir = Cells(Rows.Count, "C").End(3).Row
    SORUMLU = Range("B3").Value
    DURUM = Range("C3").Value

    Set rs1 = VBA.CreateObject("adodb.Recordset")
   
    SORGU = " SELECT F2 AS [Proje Kodu],   "
    SORGU = SORGU & vbLf & "F3 AS [Proje Adı], "
    SORGU = SORGU & vbLf & "SUM(SWITCH(F5='A',F4)) AS [Alıs],"
    SORGU = SORGU & vbLf & "SUM(SWITCH(F5='S',F4)) AS [Satıs],"
    SORGU = SORGU & vbLf & "SUM(SWITCH(F5='A',F4,F5='S',-F4)) AS [Fark]"
    SORGU = SORGU & vbLf & "FROM [VERILER$] AS [T] WHERE  F1 = '" & SORUMLU & "' AND F6 = '" & DURUM & "' "
    SORGU = SORGU & vbLf & "GROUP BY F2,F3"
     
    rs1.Open SORGU, con
    Range("h6").CopyFromRecordset rs1

   
    With Application
    .ScreenUpdating = True
    End With
    MsgBox "İşleminiz Tamamlanmıştır. " & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format((Timer - Zaman) / 60, "0.00") & " Saniye", vbInformation, "VEDAT ÖZER"
End Sub
Bu iletideki ekleri görmek için gerekli yetkilere sahip değilsiniz.
حَسْبُنَا اللهُ وَنِعْمَ الْوَكِيلُ
Allah bize yeter, O ne güzel vekildir.

vedatozer@outlook.com
Vedat ÖZER
Forum Moderatörü
 
Adı Soyadı:vedat özer
Kayıt: 12 Haz 2014 15:26
Konum: ANTALYA / KEMER
Meslek: MUHASEBE
Yaş: 29
İleti: 718
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: Antalya


Forum Genel Makro Soruları

Online Kullanıcılar

Bu forumu görüntüleyenler: Kayıtlı kullanıcı yok ve 1 misafir

Bumerang - Yazarkafe