Scripting.Dictionary nesnesi hakkında

Erdem Akdemir · 2 Şubat 2015

Merhaba,

Scripting.Dictionary nesnesini öğrenmek için bir örnek çalışma yaptım, tek sütunda işlem yapmak istediğimde yapabildim ama işin içine 2 sütun girince yöntemini bulamadım. Yapmak istediğim sayfa1'de benzersiz olanları sayfa2'de listelemek.

İlave bir sorum daha olacak , Scripting.Dictionary 'de oluşan dizinin tek haneli olarak nasıl alabilirim.

s.Keys bütün verileri kapsıyor, sadece dizideki sıra numarası yazarak nasıl getirebilirim.

Korhan Ayhan · 2 Şubat 2015

İkinci sütundaki sayılar toplanacak mı? Yani bir nevi ÖZET TABLO gibi mi işlem yapılacak?

Yoksa iki sütuna göre benzersiz kayıtlarımı listelemek istiyor sunuz?

Erdem Akdemir · 2 Şubat 2015

Korhan Ayhan' Alıntı:
İkinci sütundaki sayılar toplanacak mı? Yani bir nevi ÖZET TABLO gibi mi işlem yapılacak?

Yoksa iki sütuna göre benzersiz kayıtlarımı listelemek istiyor sunuz?

Korhan üstad benzersiz kayıtları listelemek istiyorum.

Başka bir sayfada toplam olarakta aldırabilirsiniz. İkisinide görmüş olurum.

Korhan Ayhan · 2 Şubat 2015

Aşağıdaki kod çift sütuna göre benzersiz verileri listeler.

Kod:

Sub BENZERSİZ_ÇİFT_SÜTUN()
    Dim s As Object, liste(), dizi()
    
    Son = Sheets(1).Cells(Rows.Count, "a").End(3).Row
    liste = Sheets(1).Range("a2:b" & Son).Value
    
    ReDim dizi(1 To Son, 1 To 2)
    
    Set s = CreateObject("Scripting.Dictionary")
    
    For i = 1 To UBound(liste, 1)
        Aranan = liste(i, 1) & liste(i, 2)
        If Not s.exists(Aranan) Then
            s.Add Aranan, Nothing
            Say = Say + 1
            ReDim Preserve dizi(1 To Son, 1 To 2)
            dizi(Say, 1) = liste(i, 1)
            dizi(Say, 2) = liste(i, 2)
        End If
    Next i
    
    Sheets(2).Range("A2").Resize(s.Count, 2) = dizi
End Sub

Korhan Ayhan · 2 Şubat 2015

Aşağıdaki kod ise tek sütundaki benzersizleri listelerken ikinci sütundaki verileri toplayarak rapor oluşturur. Yani bir nevi özet tablo gibi çalışır.

Kod:

Sub BENZERSİZ_TEK_SÜTUN_TOPLAMALI()
    Dim s As Object, liste(), dizi()
    
    Son = Sheets(1).Cells(Rows.Count, "a").End(3).Row
    liste = Sheets(1).Range("a2:b" & Son).Value
    
    ReDim dizi(1 To Son, 1 To 1)
    
    Set s = CreateObject("Scripting.Dictionary")
    
    For i = 1 To UBound(liste, 1)
        Aranan = liste(i, 1)
        If Not s.exists(Aranan) Then
            Say = Say + 1
            s.Add Aranan, Say
            ReDim Preserve dizi(1 To Son, 1 To 2)
            dizi(Say, 1) = liste(i, 1)
        End If
        dizi(s.Item(Aranan), 2) = dizi(s.Item(Aranan), 2) + liste(i, 2)
    Next i
    
    Sheets(2).Range("A2").Resize(s.Count, 2) = dizi
End Sub

Erdem Akdemir · 2 Şubat 2015

Hocam ellerinize sağlık, çok güzel başvuru kaynağı oldu benim için.

Hocam bir sorum daha vardı,Scripting.Dictionary dizinindeki sıra numarasına göre nasıl gösterebilirim, dizi (1) dediğimde dizinin birinci değerini getirmek gibi.

Erdem Akdemir · 2 Şubat 2015

Korhan hocam bir sorum daha olacak. Sadece "a" ları listelemek isteseydim, nasıl kodlamak gerekirdi.

Korhan Ayhan · 2 Şubat 2015

Şimdilik aşağıdaki linki inceleyiniz. Bol bol örnek var.

http://www.snb-vba.eu/VBA_Dictionary_en.html

Erdem Akdemir · 2 Şubat 2015

Korhan bey kaynak için sağolun,yine de sizden cevap bekliyorum.

Erdem Akdemir · 2 Şubat 2015

Korhan bey sadece a'ları getirebildim ama Scripting.Dictionary nesnesine hiç ihtiyacım olmadı.

Aklıma takılan Scripting.Dictionary dizinindeki sıra numarasına göre nasıl gösterebilirim, dizi (1) dediğimde dizinin birinci değerini getirmek gibi

Kod:

Option Base 1
Sub BENZERSİZ_ÇİFT_SÜTUN()
On Error Resume Next
    Dim s As Object, liste(), dizi()
    
    Son = Sheets(1).Cells(Rows.Count, "a").End(3).Row
    liste = Sheets(1).Range("a2:b" & Son).Value
    
    ReDim dizi(1 To Son, 1 To 2)
    
    Set s = CreateObject("Scripting.Dictionary")
    
    For i = 1 To UBound(liste, 1)
        aranan = liste(i, 1)
       If aranan = "a" Then
    '    If Not s.exists(aranan) Then
            s.Add aranan, Nothing
            Say = Say + 1
            ReDim Preserve dizi(1 To Son, 1 To 2)
            dizi(Say, 1) = liste(i, 1)
            dizi(Say, 2) = liste(i, 2)
        'End If
        End If
    Next i
    
    Sheets(2).Range("A2").Resize(UBound(dizi), 2) = (dizi)
End Sub

Ömer · 2 Şubat 2015

Merhaba,

MsgBox dizi(1, 2) 'dizinin 1. satır 2.sütunundaki elamanı.

İstediğiniz bu mu?

Korhan Ayhan · 3 Şubat 2015

Oluşan dizideki item değerlerine aşağıdaki gibi ulaşabilirsiniz.

Kod:

Sub Test()
    Dim d, a, i
    
    Set d = CreateObject("Scripting.Dictionary")
    
    d.Add "www", 1
    d.Add "excel", 2
    d.Add "web", 3
    d.Add "tr", 4
    
    a = d.Keys
    
    For i = 0 To d.Count - 1
        MsgBox a(i)
    Next
    
    Set d = Nothing
End Sub

Korhan Ayhan · 3 Şubat 2015

Dictionary listesi büyük veri yığınlarını çok hızlı bir şekilde derlemektedir. Bunu yaptığım testlerde gözlemledim.

Aşağıdaki kodu boş bir dosyada deneyiniz.

A sütununa 1 den 100.000 e kadar sıra numarası giriniz. Sonra kodu çalıştırıp süreyi gözlemleyiniz.

Daha sonra veri sayısını çoğaltarak süreyi test ediniz.

Ben İ7 işlemci ile 500.000 adet benzersiz veride 12 saniyede sonuç aldım. Benzer kayıt sayısı arttığında ise işlem süresi dahada kısalmaktadır.

Kod:

Sub Test()
    Dim Dizi, Liste, Zaman, Son, i
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Zaman = Timer
    
    Set Dizi = CreateObject("Scripting.Dictionary")
    
    Son = Cells(Rows.Count, 1).End(3).Row
    
    Liste = Range("A1:A" & Son)
    
    For i = 1 To UBound(Liste, 1)
        If Not Dizi.exists(Liste(i, 1)) Then
            Dizi.Add Liste(i, 1), Nothing
        End If
    Next
    
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    
    MsgBox "Benzersiz kayıt sayısı : " & Dizi.Count & Chr(10) & _
           "İşlem süresi : " & Format(Timer - Zaman, "0.00000")
    
    Set Dizi = Nothing
End Sub

Erdem Akdemir · 3 Şubat 2015

Korhan bey çok sağolun, çok faydalı bilgiler veriyorsunuz.

Aşağıdaki kodda "a" ları listeledim ama Scripting.Dictionary'i işin içine sokamadım. Onu nasıl yapabilirim.

Kod:

Option Base 1
Sub BENZERSİZ_ÇİFT_SÜTUN()
On Error Resume Next
    Dim s As Object, liste(), dizi()
    
    Son = Sheets(1).Cells(Rows.Count, "a").End(3).Row
    liste = Sheets(1).Range("a2:b" & Son).Value
    
    ReDim dizi(1 To Son, 1 To 2)
    
    Set s = CreateObject("Scripting.Dictionary")
    
    For i = 1 To UBound(liste, 1)
        aranan = liste(i, 1)
       If aranan = "a" Then
    '    If Not s.exists(aranan) Then
            s.Add aranan, Nothing
            Say = Say + 1
            ReDim Preserve dizi(1 To Son, 1 To 2)
            dizi(Say, 1) = liste(i, 1)
            dizi(Say, 2) = liste(i, 2)
        'End If
        End If
    Next i
    
    Sheets(2).Range("A2").Resize(UBound(dizi), 2) = (dizi)
End Sub

Korhan Ayhan · 5 Şubat 2015

Dictionary nesnesi verileri benzersiz mantığı ile biriktirir. Siz tekrar eden bir değere bakarak liste oluşturmak istiyorsunuz. Bu nedenle Dictionary nesnesini kullanmanıza gerek yok. Dizi yöntemiyle hızlıca sonuca gidebilirsiniz.

Kod:

Sub Test()
    Dim Liste(), Zaman, Son, Say, i
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Zaman = Timer
    
    Son = Cells(Rows.Count, 1).End(3).Row
    
    Liste = Range("A1:B" & Son)
    
    ReDim Veri(1 To Son, 1 To 2)
    
    For i = 1 To UBound(Liste, 1)
        If Liste(i, 1) = "a" Then
            Say = Say + 1
            ReDim Preserve Veri(1 To Son, 1 To 2)
            Veri(Say, 1) = Liste(i, 1)
            Veri(Say, 2) = Liste(i, 2)
        End If
    Next
    
    Range("E:F").ClearContents
    Range("E1").Resize(Say, 2) = Veri
    
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    
    MsgBox "İşlem süresi : " & Format(Timer - Zaman, "0.00000")
End Sub

Ömer BARAN · 8 Şubat 2015

Korhan Ayhan' Alıntı:

Aşağıdaki kod ise tek sütundaki benzersizleri listelerken ikinci sütundaki verileri toplayarak rapor oluşturur. Yani bir nevi özet tablo gibi çalışır.

Kod:

Sub BENZERSİZ_TEK_SÜTUN_TOPLAMALI()
    Dim s As Object, liste(), dizi()
    
    Son = Sheets(1).Cells(Rows.Count, "a").End(3).Row
    liste = Sheets(1).Range("a2:b" & Son).Value
    
    ReDim dizi(1 To Son, 1 To 1)
    
    Set s = CreateObject("Scripting.Dictionary")
    
    For i = 1 To UBound(liste, 1)
        Aranan = liste(i, 1)
        If Not s.exists(Aranan) Then
            Say = Say + 1
            s.Add Aranan, Say
            ReDim Preserve dizi(1 To Son, 1 To 2)
            dizi(Say, 1) = liste(i, 1)
        End If
        dizi(s.Item(Aranan), 2) = dizi(s.Item(Aranan), 2) + liste(i, 2)
    Next i
    
    Sheets(2).Range("A2").Resize(s.Count, 2) = dizi
End Sub

Merhabalar Sayın AYHAN, bu konudaki mesaj ve açıklamalardan anladığım
kadarıyla, benim derdimin çözümü de bu kodlardan geçiyor, birkaç eksiğine
rağmen sizlerin katkılarıyla oluşturduğum ekteki excel belgeme bir göz atabilir misiniz acaba?

Mevcut belgemde sonuç almam 100-110 saniye sürüyor.
Eğer sizin buradaki kodlarınızı kullanabilseydim birkaç saniyede sonuç alacağımı sanıyorum.

Ekteki excel belgesinin, birkaç gizli sayfa ve yerleşik fonksiyonları kullanan makroların
NİHAİ AMACI, TABLO1 sayfasında
-- E2 (veri doğrulama seçimine göre F4:AU4 aralığı oluşturuluyor),
--E3 (veri doğrulama seçimine göre F3:AU3 aralığı oluşturuluyor) VE
--E4 (veri doğrulama seçimine göre E8:E17 aralığı oluşturuluyor)
hücrelerindeki seçimlere göre oluşan tablo sütun ve satır başlıklarına göre LİSTE sayfasının;

1) koşullara uyan satırlarında, C sütunundaki
BENZERSİZ VERİ SAYIMININ,

2) koşullara uyan SATIR SAYIMININ

yapılması ve TABLO1 sayfasında satır ve sütun başlıklarına göre ilgili alanlara yazılması.

NOT : Belgemdeki mevcut makro ve sayfaların çalışma mantığını; LİSTE ve TABLO1 sayfalarındaki
METİN KUTULARINDA ve SEÇİM sayfası Q ve R sütunlarında elimden geldiğince anlaşılır şekilde açıkladım.

Ömer BARAN · 14 Şubat 2015

CreateObject("Scripting.Dictionary") yöntemini kullanarak, bir üstteki mesajımda yer alan belgemi açıp mevcut makro çalıştırıldığında alınan sonuçlara, çok kısa sürede ulaşılacağını düşündüğümden destek rica etmiştim.
Sayın AYHAN veya konuyu bilen bir üye ilgilenirse sevinirim.
Yapılacak işlem liste sayfası DR sütununda, TABLO1 sayfamdaki satır ve sütun başlıklarına göre ilgili sütunlardaki bilgiler, aralara " | " eklenerek metne dönüştürülmesi halinde (bu dönüştürme işlemi belgemdeki SAYIM2 makrosuna kadarki kısımda gerçekleşiyor) bulunduğu satırlarda C sütunundaki farklı değer sayısı ile eşleşmenin olduğu satır sayısının TABLO1 sayfasında F5 : AU17 aralığına yazdırılması gerekiyor.
Örnek dosyamda TABLO1 sayfasındaki düğme kullanılarak mevcut makrolar çalıştırıldığında oluşan makro sonuçlarından anlaşılacağını düşünüyorum.

Korhan Ayhan · 17 Şubat 2015

Merhaba Ömer Bey,

Eklemiş olduğunuz dosyanıza boş bir sayfa ekleyin. Adı "Sayfa1" olsun.

Daha sonra diğer sayfanızdan seçimlerinizi yaptıktan sonra aşağıdaki kodu deneyin.

Kod:

Option Explicit

Sub ÖZET_TABLO()
    Dim S1 As Worksheet, S2 As Worksheet, S3 As Worksheet
    Dim Zaman As Double, Son As Long, Nesne As Object, Liste()
    Dim Sutun1 As String, Sutun2 As String, Sutun3 As String
    Dim X As Long, Kriter As String, Say As Long
    Dim Tablo As PivotTable, Sutun As PivotField
    
    Zaman = Timer
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    
    Set S1 = Sheets("LİSTE")
    Set S2 = Sheets("TABLO1")
    Set S3 = Sheets("Sayfa1")
    
    S3.Cells.Clear
    
    On Error Resume Next
    Son = S1.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    If Son = 0 Then Son = 100000
    On Error GoTo 0
    
    Sutun1 = S2.Range("AG2")
    Sutun2 = S2.Range("AH2")
    Sutun3 = S2.Range("AI2")
    
    S3.Range(S3.Cells(1, 1), S3.Cells(Son - 6, 1)) = S1.Range(S1.Cells(7, Sutun2), S1.Cells(Son, Sutun2)).Value2
    S3.Range(S3.Cells(1, 2), S3.Cells(Son - 6, 2)) = S1.Range(S1.Cells(7, Sutun1), S1.Cells(Son, Sutun1)).Value2
    S3.Range(S3.Cells(1, 3), S3.Cells(Son - 6, 3)) = S1.Range(S1.Cells(7, Sutun3), S1.Cells(Son, Sutun3)).Value2
    S3.Range(S3.Cells(1, 4), S3.Cells(Son - 6, 4)) = S1.Range(S1.Cells(7, 3), S1.Cells(Son, 3)).Value2

    Set Nesne = CreateObject("Scripting.Dictionary")

    Liste = S3.Range("A1").CurrentRegion.Resize(, 4).Value
    ReDim Dizi(1 To 4, 1 To 1)
    
    For X = 1 To UBound(Liste, 1)
        Kriter = Liste(X, 1) & "#" & Liste(X, 2) & "#" & Liste(X, 3) & "#" & Liste(X, 4)
        If Not Nesne.Exists(Kriter) Then
            Say = Say + 1
            Nesne.Add Kriter, Say
            ReDim Preserve Dizi(1 To 4, 1 To Say)
            Dizi(1, Say) = Liste(X, 1)
            Dizi(2, Say) = Liste(X, 2)
            Dizi(3, Say) = Liste(X, 3)
            Dizi(4, Say) = Liste(X, 4)
        End If
    Next
        
    S3.Range("A1").Select
    S3.Range("A1").Resize(Rows.Count, 4).ClearContents
    S3.Range("A1").Resize(Say, 4) = Application.Transpose(Dizi)
        
    Set Tablo = S3.PivotTableWizard(, , S3.Range("H1"))
    Set Sutun = Tablo.PivotFields(S3.Range("A1").Text)
    Sutun.Orientation = xlColumnField
    Set Sutun = Tablo.PivotFields(S3.Range("B1").Text)
    Sutun.Orientation = xlColumnField
    Set Sutun = Tablo.PivotFields(S3.Range("C1").Text)
    Sutun.Orientation = xlRowField
    Set Sutun = Tablo.PivotFields("Hasta No")
    Sutun.Orientation = xlDataField
    Sutun.Function = xlCount
    
    S3.Cells.EntireColumn.AutoFit

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    
    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & "İşlem süresi ; " & Format(Timer - Zaman, "0.00000")
End Sub

KarıncaZ · 9 Kasım 2017

Scripting.Dictionary yardım.

Merhaba.

Konuyu araştırdım yazılanları da okudum ancak bir türlü yapamadım.
Linkdeki dosyada çalışan makroların Scripting.Dictionary ile yada daha hızlı sonuç verecek bir yöntemle yapılması mümkün mü?

Veri sayısı çok fazla. Ben verilerin yarısını ekleyerek örnek dosyayı hazırladım.

http://s5.dosya.tc/server5/v44sbr/EsnekRaporlama.zip.html

İkiTarihMizan Sayfasında şekillere atadığım makroların kısa sürede gerçekleşmesi çok önemli. Benim yazdıklarımın sonuçlanması çok uzun sürüyor bazende excel yanıt vermediği için kapatmak zorunda kalıyorum. Yevmiye sayfasında şekillere atadığım makroların sonuçlanması nispeten kabul edile bilir sürede.

Yardımlarınız için şimdiden teşekkürler.

Ziynettin · 11 Kasım 2017

Merhaba,

İkiTarihMizan sayfasında [C, D, E, F] sütunları için kodu bu şekilde kullanın.

Kod:

Private Sub CommandButton1_Click()
Z = TimeValue(Now)
Application.ScreenUpdating = False
Set s1 = Sheets("Yevmiye")
Set s2 = Sheets("İkiTarihMizan")
Set d = CreateObject("scripting.dictionary")
ss1 = s1.Cells(Rows.Count, 1).End(xlUp).Row
ss2 = s2.Cells(Rows.Count, 1).End(xlUp).Row
trh1 = CDate(s2.[A1])
trh2 = CDate(s2.[A2])
a = s1.Range("A2:M" & ss1)
ReDim b(1 To UBound(a), 1 To 8)

For i = 1 To UBound(a)
    If a(i, 2) >= trh1 And a(i, 2) <= trh2 Then
        veri = a(i, 4)
        If Not d.exists(veri) Then
            say = say + 1
            d(a(i, 4)) = say
            If Len(veri) >= 3 Then b(say, 1) = Left((veri), 3)
            If Len(veri) >= 6 Then b(say, 2) = Left((veri), 6)
            If Len(veri) >= 7 Then b(say, 3) = Left((veri), 7)
            If Len(veri) >= 9 Then b(say, 4) = Left(veri, 9)
            If Len(veri) >= 10 Then b(say, 5) = Left(veri, 10)
            If Len(veri) >= 11 Then b(say, 6) = Left(veri, 11)
        End If
        sat = d(a(i, 4))
        b(sat, 7) = b(sat, 7) + a(i, 7)
        b(sat, 8) = b(sat, 8) + a(i, 8)
    End If
Next i
'****************************************************************

tbl = Array(b)
Erase b
d.RemoveAll
ReDim b(1 To say*2, 1 To 3)

For i = 1 To say
    For j = 1 To 6
        veri = CStr(tbl(0)(i, j))
        If Not IsEmpty(veri) Then
            If Not d.exists(veri) Then
                say1 = say1 + 1
                d(veri) = say1
                b(say1, 1) = CStr(veri)
            End If
            b(d(veri), 2) = b(d(veri), 2) + tbl(0)(i, 7)
            b(d(veri), 3) = b(d(veri), 3) + tbl(0)(i, 8)
        End If
    Next j
Next i
'****************************************************************

k = s2.Range("A4:A" & ss2)
On Error Resume Next
ReDim c(1 To UBound(k), 1 To 4)

For i = 1 To UBound(k)
    n = n + 1
    c(n, 1) = 0
    c(n, 2) = 0
    c(n, 3) = 0
    c(n, 4) = 0
    c(n, 1) = b(d(CStr(k(i, 1))), 2)
    c(n, 2) = b(d(CStr(k(i, 1))), 3)
    If b(d(CStr(k(i, 1))), 2) > b(d(CStr(k(i, 1))), 3) Then
        c(n, 3) = b(d(CStr(k(i, 1))), 2) - b(d(CStr(k(i, 1))), 3)
    Else
        c(n, 4) = b(d(CStr(k(i, 1))), 3) - b(d(CStr(k(i, 1))), 2)
    End If
Next i
'*************************************************************************

s2.[C4].Resize(n, 4) = c
s2.[C4].Resize(n, 4).NumberFormat = "#,##0.00"
Application.ScreenUpdating = True
MsgBox CDate(TimeValue(Now) - Z)
End Sub

https://www.dosyaupload.com/54w6

Scripting.Dictionary nesnesi hakkında

Destek Ekibi

Ekli dosyalar

Administrator

Destek Ekibi

Administrator

Administrator

Destek Ekibi

Destek Ekibi

Administrator

Destek Ekibi

Destek Ekibi

Moderatör

Administrator

Administrator

Destek Ekibi

Administrator

Uzman

Ekli dosyalar

Uzman

Administrator

Destek Ekibi