Excel Forum

Excel Forum (http://www.excel.web.tr/index.php)
-   Makro-VBA (http://www.excel.web.tr/forumdisplay.php?f=48)
-   -   Scripting.Dictionary nesnesi hakkında (http://www.excel.web.tr/showthread.php?t=146392)

Ömer 02-02-2015 22:22

Merhaba,

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

İstediğiniz bu mu?

Korhan Ayhan 02-02-2015 23:08

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 02-02-2015 23:42

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


kuvari 03-02-2015 12:09

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 05-02-2015 02:27

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 08-02-2015 14:59

1 Eklenti(ler)
Alıntı:

Korhan Ayhan tarafından gönderildi (Mesaj 795276)
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-02-2015 22:21

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-02-2015 00:19

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 09-11-2017 11:45

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/Es...rlama.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-11-2017 00:34

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


Saat 12:53

Powered by vBulletin Version 3.7.2
Copyright ©2000 - 2017, Jelsoft Enterprises Ltd.