Scripting.dictionary çalışma hatası

Vedat Özer · 9 Aralık 2015

Merhabalar,

Bir üyemizin sormuş olduğu sorunun cevabını biraz inceledim sonuca Scripting.dictionary ile gittim fakat kod 65.000 satırda çalışmasında bir sıkıntı yokken 66.000 ve satır sayısını arttıkça kodda hata meydana geliyo.

sp.Range("A4").Resize(z.Count, 14).Value = Application.Transpose(dizi)
Hata veren satır. .

Teşekkür Ederim..

Kod:

Option Base 1
Sub vedat()
Dim sonsat As Long, sp As Worksheet, sh As Worksheet, liste(), son, dizi(), n As Long, z As Object
Dim i, sat As Long, deg As String
Dim Sure As Double, Zaman As Double

Zaman = Timer
     
     With Application
       .ScreenUpdating = False
       .Calculation = xlCalculationManual
     .EnableEvents = False
     End With
Sheets("detay rapor").Select
Range("A4:N" & Rows.Count).ClearContents
Range("A4:N" & Rows.Count).Borders.LineStyle = 0
Set sh = Sheets("veri tabanı")
Set sp = Sheets("detay rapor")
sonsat = sh.Cells(sh.Rows.Count, "A").End(xlUp).Row
liste = sh.Range("A2:AG" & sonsat).Value

ReDim dizi(1 To 14, 1 To sonsat)
Set z = CreateObject("Scripting.dictionary")
For i = 1 To UBound(liste)
    If liste(i, 13) >= Range("Q1").Value And liste(i, 14) <= Range("Q2").Value Then
        deg = liste(i, 7) & liste(i, 11)
        If Not z.exists(deg) Then
             n = n + 1
             z.Add deg, n
             dizi(1, n) = liste(i, 7)
             dizi(2, n) = liste(i, 11)
             ReDim Preserve dizi(1 To 14, 1 To sonsat)
              
        End If
             dizi(3, z.Item(deg)) = dizi(3, z.Item(deg)) + liste(i, 16)
             dizi(5, z.Item(deg)) = dizi(5, z.Item(deg)) + liste(i, 15)
             dizi(6, z.Item(deg)) = dizi(6, z.Item(deg)) + liste(i, 18)
             dizi(8, z.Item(deg)) = dizi(8, z.Item(deg)) + liste(i, 17)
             dizi(9, z.Item(deg)) = dizi(9, z.Item(deg)) + liste(i, 28)
             dizi(11, z.Item(deg)) = dizi(11, z.Item(deg)) + liste(i, 29)
             dizi(12, z.Item(deg)) = dizi(12, z.Item(deg)) + liste(i, 30)
             dizi(14, z.Item(deg)) = dizi(14, z.Item(deg)) + liste(i, 31)
    End If
Next i

sp.Range("A4").Resize(z.Count, 14).Value = Application.Transpose(dizi)

Erase liste
Erase dizi
Set z = Nothing
Set sh = Nothing
Set sp = Nothing

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

Vedat Özer · 9 Aralık 2015

Konuyla alakalı alternatif çözümü varmı ?

halit3 · 10 Aralık 2015

Belki olabilir örnek dosyayı görmek lazım.

Vedat Özer · 10 Aralık 2015

İlginiz için teşekkür ederim.

Örnek dosya ekte.

halit3 · 10 Aralık 2015

kod:

Kod:

Sub Gruplandir()

ZBasla = TimeValue(Now)
Zaman = Timer

Set s1 = Sheets("veri tabanı") ' veri sayfası
Set s2 = Sheets("detay rapor") 'aktarılan sayfa



s2.Range("a4:n" & Rows.Count).ClearContents '.Clear
son1 = s1.Cells(Rows.Count, "a").End(3).Row
aranan1 = CDate(s2.Cells(1, 17).Value)
aranan2 = CDate(s2.Cells(2, 17).Value)

ReDim ara1(son1): ReDim ara2(son1):: ReDim ara3(son1):: ReDim ara4(son1):

For j = 2 To son1
ara1(j) = WorksheetFunction.Trim(s1.Cells(j, "h")) & WorksheetFunction.Trim(s1.Cells(j, "k"))
ara2(j) = 1
ara3(j) = CDate(s1.Cells(j, "M").Value)
ara4(j) = CDate(s1.Cells(j, "N").Value)

Next j

sat1 = 4

For r = 2 To son1
bulunan1 = ara1(r)

sut15 = 0
sut16 = 0
sut17 = 0
sut18 = 0

sut28 = 0
sut29 = 0

sut30 = 0
sut31 = 0

If ara2(r) = 1 Then

For i = r To son1
If ara1(i) = bulunan1 Then

If ara3(i) >= aranan1 And ara4(i) <= aranan2 Then

sut15 = sut15 + CDbl(s1.Cells(i, 15).Value)
sut16 = sut16 + CDbl(s1.Cells(i, 16).Value)
sut17 = sut17 + CDbl(s1.Cells(i, 17).Value)
sut18 = sut18 + CDbl(s1.Cells(i, 18).Value)

sut28 = sut28 + CDbl(s1.Cells(i, 28).Value)
sut29 = sut29 + CDbl(s1.Cells(i, 29).Value)

sut30 = sut30 + CDbl(s1.Cells(i, 30).Value)
sut31 = sut31 + CDbl(s1.Cells(i, 31).Value)
End If
ara2(i) = 0
End If
Next i

s2.Cells(sat1, 1).Value = s1.Cells(r, 7).Value
s2.Cells(sat1, 2).Value = s1.Cells(r, 11).Value
s2.Cells(sat1, 3).Value = sut16
s2.Cells(sat1, 5).Value = sut15


s2.Cells(sat1, 6).Value = sut18
s2.Cells(sat1, 8).Value = sut17

s2.Cells(sat1, 9).Value = sut28
s2.Cells(sat1, 11).Value = sut29

s2.Cells(sat1, 12).Value = sut30
s2.Cells(sat1, 14).Value = sut31


sat1 = sat1 + 1

End If
Next r

zBitis = TimeValue(Now)

MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & _
"İşlem süresi ; " & Format(Timer - Zaman, "0.00") & Chr(10) & _
"Geçen Süre " & CDate(zBitis - ZBasla), vbInformation, " Sonuç Penceresi"

End Sub

Vedat Özer · 10 Aralık 2015

Halit bey sağolun alternatif çözüm için..

Scripting.dictionary neden belli bir satır sayısını geçtikten sonra hata veriyo onu araştırıyorum..

halit3 · 10 Aralık 2015

Vedat Özer' Alıntı:
Halit bey sağolun alternatif çözüm için..

Scripting.dictionary neden belli bir satır sayısını geçtikten sonra hata veriyo onu araştırıyorum..

Vedat bey kodun hızını test ettinizmi

Korhan Ayhan · 11 Aralık 2015

Vedat Bey,

"Scripting.Dictionary" ile ilgili olarak aşağıdaki kodu deneyiniz.

100.000 satırda İ7 işlemcide 10 saniye civarında sonuç veriyor.

Kod:

Option Explicit

Sub Ozet_Tablo()
    Dim S1 As Worksheet, S2 As Worksheet, Son As Long, X As Long, Say As Long
    Dim Veri As Variant, Liste As Variant, Zaman As Double, Kriter As String
    
    Zaman = Timer
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    
    Set S1 = Sheets("veri tabanı")
    Set S2 = Sheets("detay rapor")
    
    S2.Range("A4:O" & S2.Rows.Count).ClearContents
    S2.Range("A4:O" & S2.Rows.Count).Borders.LineStyle = 0
    
    Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
    Veri = S1.Range("A2:AG" & Son).Value
    
    ReDim Liste(1 To UBound(Veri, 1), 1 To 15)
    
    With CreateObject("Scripting.Dictionary")
        .CompareMode = vbTextCompare
        For X = 1 To UBound(Veri, 1)
            If Veri(X, 13) >= S2.Range("R1") And Veri(X, 14) <= S2.Range("R2") Then
                Kriter = Veri(X, 11)
                If Not IsEmpty(Kriter) Then
                    If Not .Exists(Kriter) Then
                        Say = Say + 1
                        .Add Kriter, Say
                        Liste(Say, 1) = Veri(X, 7)
                        Liste(Say, 2) = Veri(X, 11)
                        Liste(Say, 3) = Veri(X, 12)
                    End If
                    
                    On Error Resume Next
                    Liste(.Item(Kriter), 4) = Liste(.Item(Kriter), 4) + Veri(X, 16)
                    Liste(.Item(Kriter), 6) = Liste(.Item(Kriter), 6) + Veri(X, 15)
                    Liste(.Item(Kriter), 5) = Liste(.Item(Kriter), 6) / Liste(.Item(Kriter), 4)
                
                    Liste(.Item(Kriter), 7) = Liste(.Item(Kriter), 7) + Veri(X, 18)
                    Liste(.Item(Kriter), 9) = Liste(.Item(Kriter), 9) + Veri(X, 17)
                    Liste(.Item(Kriter), 8) = Liste(.Item(Kriter), 9) / Liste(.Item(Kriter), 7)
                
                    Liste(.Item(Kriter), 10) = Liste(.Item(Kriter), 10) + Veri(X, 28)
                    Liste(.Item(Kriter), 12) = Liste(.Item(Kriter), 12) + Veri(X, 29)
                    Liste(.Item(Kriter), 11) = Liste(.Item(Kriter), 12) / Liste(.Item(Kriter), 10)
                
                    Liste(.Item(Kriter), 13) = Liste(.Item(Kriter), 13) + Veri(X, 30)
                    Liste(.Item(Kriter), 15) = Liste(.Item(Kriter), 15) + Veri(X, 31)
                    Liste(.Item(Kriter), 14) = Liste(.Item(Kriter), 15) / Liste(.Item(Kriter), 13)
                    On Error GoTo 0
                End If
            End If
        Next
    End With
    
    S2.Range("A4").Resize(Say, 15).Value = Liste
    S2.Range("A4").Resize(Say, 15).Borders.LineStyle = 1
    S2.Cells.EntireColumn.AutoFit
    S2.Select
    
    Set S1 = Nothing
    Set S2 = Nothing
    
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    
    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.000") & " Saniye", vbInformation, "Bilgilendirme"
End Sub

halit3 · 11 Aralık 2015

Bu kod da farklı bir alternatif.

Kod:

Sub Gruplandir()

Zaman = Timer

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False

Set s1 = Sheets("veri tabanı") ' veri sayfası
Set s2 = Sheets("detay rapor") 'aktarılan sayfa

s2.Range("a4:n" & Rows.Count).ClearContents '.Clear
son1 = s1.Cells(Rows.Count, "a").End(3).Row
aranan1 = CDate(s2.Cells(1, 17).Value)
aranan2 = CDate(s2.Cells(2, 17).Value)
ReDim myarr2(1 To son1, 1 To 14)
ReDim ara1(son1): ReDim ara2(son1):: ReDim ara3(son1):: ReDim ara4(son1):

For j = 2 To son1
ara1(j) = WorksheetFunction.Trim(s1.Cells(j, "h")) & WorksheetFunction.Trim(s1.Cells(j, "k"))
ara2(j) = 1
ara3(j) = CDate(s1.Cells(j, "M").Value)
ara4(j) = CDate(s1.Cells(j, "N").Value)
Next j

sat1 = 1

For r = 2 To son1
bulunan1 = ara1(r)

sut15 = 0
sut16 = 0
sut17 = 0
sut18 = 0
sut28 = 0
sut29 = 0
sut30 = 0
sut31 = 0

If ara2(r) = 1 Then

For i = r To son1
If ara1(i) = bulunan1 Then

If ara3(i) >= aranan1 And ara4(i) <= aranan2 Then
sut15 = sut15 + CDbl(s1.Cells(i, 15).Value)
sut16 = sut16 + CDbl(s1.Cells(i, 16).Value)
sut17 = sut17 + CDbl(s1.Cells(i, 17).Value)
sut18 = sut18 + CDbl(s1.Cells(i, 18).Value)
sut28 = sut28 + CDbl(s1.Cells(i, 28).Value)
sut29 = sut29 + CDbl(s1.Cells(i, 29).Value)
sut30 = sut30 + CDbl(s1.Cells(i, 30).Value)
sut31 = sut31 + CDbl(s1.Cells(i, 31).Value)
End If
ara2(i) = 0
End If
Next i




ReDim Preserve myarr2(1 To son1, 1 To 14)
myarr2(sat1, 1) = s1.Cells(r, 7).Value
myarr2(sat1, 2) = s1.Cells(r, 11).Value
myarr2(sat1, 3) = sut16
myarr2(sat1, 4) = ""
myarr2(sat1, 5) = sut15

myarr2(sat1, 6) = sut18
myarr2(sat1, 7) = ""
myarr2(sat1, 8) = sut17

myarr2(sat1, 9) = sut29
myarr2(sat1, 10) = ""
myarr2(sat1, 11) = sut28

myarr2(sat1, 12) = sut31
myarr2(sat1, 13) = ""
myarr2(sat1, 14) = sut30
sat1 = sat1 + 1

End If
Next r

Range("a4", Cells(sat1 + 2, 14)).Value = myarr2

Application.EnableEvents = True
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

zBitis = TimeValue(Now)

MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & _
"İşlem süresi ; " & Format(Timer - Zaman, "0.00") & Chr(10) & _
"Geçen Süre " & CDate(zBitis - ZBasla), vbInformation, " Sonuç Penceresi"

End Sub

Vedat Özer · 11 Aralık 2015

Selamlar,

Bilgisayar işlemcisi İ5

Halit bey,

İlk Kodunuz 14 Saniye Civarında
İkinci Kodunuz 14 Saniye Civarında

Korhan bey,

9 Saniye Civarında Rapor oluşturdu.

Her ikinizede ayrı ayrı Teşekkür ederim.

halit3 · 12 Aralık 2015

Vedat Bey çok verili örnek dosyayı buraya veya benim mailime bir gönderinde şu süre hesaplamaya birde ben bakayım.

Korhan Ayhan · 12 Aralık 2015

Halit Bey,

Sizin eklediğiniz kodu 100.000 satırlık benzersiz veride denedim.

İlk öneriniz yaklaşık 6 dakika 46 saniye sürdü.
ikinci öneriniz yaklaşık 6 dakika 11 saniye sürdü.

Ayrıca sizin kodlarınız da ortalama birim fiyat hesaplanmıyor.

Benim önerdiğim kod ise 25 saniyede sonuç üretiyor.

Erdem Akdemir · 12 Aralık 2015

Vedat bey merhaba,

Alternatif olarak ADO yöntemini deneyebilir misiniz? 100.000 satır veride i5 işlemci ile 2 - 2,5 saniye arasında sonuç aldım.

Kod:

Sub deneme()
    Zaman = Timer
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    Son = Sayfa2.Cells(Rows.Count, "a").End(3).Row

Sayfa2.Range("a4:o" & Son).ClearContents

Set con = VBA.CreateObject("adodb.Connection")

con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
ThisWorkbook.FullName & ";extended properties=""Excel 12.0;hdr=yes"""

sorgu = "select SGRUPKODU,STOKADI,BIRIM , Sum([DEVIRMIKTAR]), avg([ORTFIYAT]), Sum([DEVIRTUTAR]), Sum([ALIMMIKTAR]), "
sorgu = sorgu & "avg([ORTFIYAT]),sum([ALIMTUTAR]),sum([SAYIM]),avg([ORTFIYAT]),sum([SAYIMTUTAR]),"
sorgu = sorgu & "sum([TUKETILENMIKTAR]),avg([ORTFIYAT]),sum([TUKETILENTUTAR]) from [veri tabanı$] group by SGRUPKODU,STOKADI,BIRIM "

Set rs = con.Execute(sorgu)

Sayfa2.Range("a4").CopyFromRecordset rs

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

End Sub

halit3 · 12 Aralık 2015

Korhan Bey Hangi örnek dosyada bu kodları deniyorsanız ekleyebilirmisiniz.

halit3 · 12 Aralık 2015

Sayın kuvari sizde deneme yaptığınız örnek dosyayı ekleyebilirmisiniz.

Erdem Akdemir · 12 Aralık 2015

Halit bey merhaba,

Ben örnek dosyayı A21 hücresine A2 hücresini referans göstererek yana ve aşağı doğru kopyalama yaparak oluşturdum. Dosyanın boyutu 30 MB civarı oldu.

Zeki Gürsoy · 12 Aralık 2015

problemli dosya 2003 xls olabilir mi?

Vedat Özer · 13 Aralık 2015

Selamlar,

Halit bey,

Örnek dosya ektedir.

halit3 · 13 Aralık 2015

Vadat Bey son eklediğiniz dosya ile ilgili Benim bilgisayarda Korhan beyin kodu 17 sn de Benim kodum 35 sn de aşağıdaki kırmızı yeri sildiğimde 30 sn de işlem görmekte ayrıca kodda ortalama tutarlarıda ekledim bence benzersiz kayıtlarda kriter fazla olduğunda En etkili yöntem Redim metodudur kriter az olduğunda Scripting.Dictionary metodu daha etkilidir.

Şunuda paylaşmak isterim yazdığım kodlarda On Error Resume Next metotunu genelde hiç kullanmamaya çalışıyorum

kod:

Kod:

Sub Gruplandir()

Zaman = Timer

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False

Set S1 = Sheets("veri tabanı") ' veri sayfası
Set S2 = Sheets("Halit ÖZDEMİR Özet Rapor") 'aktarılan sayfa

S2.Range("a4:n" & Rows.Count).ClearContents '.Clear
son1 = S1.Cells(Rows.Count, "a").End(3).Row
aranan1 = CDate(S2.Cells(1, 17).Value)
aranan2 = CDate(S2.Cells(2, 17).Value)
ReDim myarr2(1 To son1, 1 To 14)
ReDim ara1(son1): ReDim ara2(son1):: ReDim ara3(son1):: ReDim ara4(son1):

For j = 2 To son1
'ara1(j) = [COLOR="Red"]WorksheetFunction.Trim(S1.Cells(j, "h")) [/COLOR]& WorksheetFunction.Trim(S1.Cells(j, "k"))
ara1(j) = WorksheetFunction.Trim(S1.Cells(j, "k"))
ara2(j) = 1
ara3(j) = CDate(S1.Cells(j, "M").Value)
ara4(j) = CDate(S1.Cells(j, "N").Value)
Next j

sat1 = 1

For r = 2 To son1
bulunan1 = ara1(r)

sut15 = 0
sut16 = 0
sut17 = 0
sut18 = 0
sut28 = 0
sut29 = 0
sut30 = 0
sut31 = 0

If ara2(r) = 1 Then

For i = r To son1
If ara1(i) = bulunan1 Then

If ara3(i) >= aranan1 And ara4(i) <= aranan2 Then
sut15 = sut15 + CDbl(S1.Cells(i, 15).Value)
sut16 = sut16 + CDbl(S1.Cells(i, 16).Value)
sut17 = sut17 + CDbl(S1.Cells(i, 17).Value)
sut18 = sut18 + CDbl(S1.Cells(i, 18).Value)
sut28 = sut28 + CDbl(S1.Cells(i, 28).Value)
sut29 = sut29 + CDbl(S1.Cells(i, 29).Value)
sut30 = sut30 + CDbl(S1.Cells(i, 30).Value)
sut31 = sut31 + CDbl(S1.Cells(i, 31).Value)
End If
ara2(i) = 0
End If
Next i



ReDim Preserve myarr2(1 To son1, 1 To 14)
myarr2(sat1, 1) = S1.Cells(r, 7).Value
myarr2(sat1, 2) = S1.Cells(r, 11).Value


myarr2(sat1, 3) = sut16
If sut15 > 0 Then
myarr2(sat1, 4) = sut15 / sut16
Else
myarr2(sat1, 4) = ""
End If
myarr2(sat1, 5) = sut15


myarr2(sat1, 6) = sut18
If sut17 > 0 Then
myarr2(sat1, 7) = sut17 / sut18
Else
myarr2(sat1, 7) = ""
End If
myarr2(sat1, 8) = sut17

myarr2(sat1, 9) = sut28
If sut29 > 0 Then
myarr2(sat1, 10) = sut29 / sut28
Else
myarr2(sat1, 10) = ""
End If
myarr2(sat1, 11) = sut29

myarr2(sat1, 12) = sut30
If sut31 > 0 Then
myarr2(sat1, 13) = sut31 / sut30
Else
myarr2(sat1, 13) = ""
End If
myarr2(sat1, 14) = sut31



sat1 = sat1 + 1

End If
Next r

Range("a4", Cells(sat1 + 2, 14)).Value = myarr2

Application.EnableEvents = True
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

zBitis = TimeValue(Now)

MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & _
"İşlem süresi ; " & Format(Timer - Zaman, "0.00") & Chr(10) & _
"Geçen Süre " & CDate(zBitis - ZBasla), vbInformation, " Sonuç Penceresi"

End Sub

Erdem Akdemir · 13 Aralık 2015

Halit bey benim yazdığım kodu denediniz mi?

Scripting.dictionary çalışma hatası

Vedat Özer

Vedat Özer

halit3

Uzman

Vedat Özer

Ekli dosyalar

halit3

Uzman

Vedat Özer

halit3

Uzman

Korhan Ayhan

Administrator

Ekli dosyalar

halit3

Uzman

Vedat Özer

halit3

Uzman

Korhan Ayhan

Administrator

Erdem Akdemir

Destek Ekibi

halit3

Uzman

halit3

Uzman

Erdem Akdemir

Destek Ekibi

Zeki Gürsoy

Uzman

Vedat Özer

Ekli dosyalar

halit3

Uzman

Erdem Akdemir

Destek Ekibi