Dizi İçinde toplama

[bebar]

Merhaba,
Aşağıdaki resimde olduğu olduğu gibi bir tablom var tablomun içinde mağazaların;
*ürün kodu
*renk kodu
*beden
satış ve envanterlerini gösteriyor.
ben ise aynı tablonun yanına mağazalarının ürün kodu ve renk kodu satışlarını getiriyorum yani ürün kodunun renginin toplam beden satışı ve envanteri ilgili alana yazdırıyorum yada dizi içine alıyorum.
Aşağıdaki gibi bir kod oluşturdum çalışıyor ama 100 binli satırlara çıkınca çok ama çok yavaşlıyor.
scraping dictionary ile yapmaya çalıştım fakat olmadı yardımcı olursanız memnun olurum.

Sub deneme()
Dim dizi()
Dim x As Long, Veri As Variant, j As Long, i As Long, t As Long
x = Cells(Rows.Count, 2).End(xlUp).Row
    ReDim dizi(1 To x, 1 To 10)
        For i = LBound(dizi, 1) To UBound(dizi, 1)
            For j = LBound(dizi, 2) To UBound(dizi, 2)
            dizi(i, j) = Cells(i + 3, j + 1)
            Next j
        Next i
        For i = LBound(dizi, 1) To UBound(dizi, 1)
            For j = LBound(dizi, 1) To UBound(dizi, 1)
            k = dizi(i, 1) & dizi(i, 2) & dizi(i, 5)
            k1 = dizi(j, 1) & dizi(j, 2) & dizi(j, 5)
                If k = k1 Then
                
                   dizi(i, 8) = dizi(i, 8) + dizi(j, 6)
                   dizi(i, 9) = dizi(i, 9) + dizi(j, 7)
                  
                    If dizi(j, 7) <> "" Then
                        dizi(i, 10) = dizi(i, 10) + 1
                    End If
                    
                End If
            Next j
        Next i
        Range("m4:v" & x) = dizi
End Sub

 

[systran]

şu şekilde deneyiniz.

Sub deneme()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Dim dizi()
Dim x As Long, Veri As Variant, j As Long, i As Long, t As Long
x = Cells(Rows.Count, 2).End(xlUp).Row
ReDim dizi(1 To x, 1 To 10)
For i = LBound(dizi, 1) To UBound(dizi, 1)
For j = LBound(dizi, 2) To UBound(dizi, 2)
dizi(i, j) = Cells(i + 3, j + 1)
Next j
Next i
For i = LBound(dizi, 1) To UBound(dizi, 1)
For j = LBound(dizi, 1) To UBound(dizi, 1)
k = dizi(i, 1) & dizi(i, 2) & dizi(i, 5)
k1 = dizi(j, 1) & dizi(j, 2) & dizi(j, 5)
If k = k1 Then

dizi(i, 8) = dizi(i, 8) + dizi(j, 6)
dizi(i, 9) = dizi(i, 9) + dizi(j, 7)

If dizi(j, 7) <> "" Then
dizi(i, 10) = dizi(i, 10) + 1
End If

End If
Next j
Next i
Range("m4:v" & x) = dizi
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

 

[bebar]

Biraz daha hızlı geldi teşekkür ederim hocam

 

[Ziynettin]

Ekli dosyayı deneyin.

 

[bebar]

hocam çok teşekkür ederim konu arkada kaldığı için dikkat etmedim.
allah razı olsun çok işimi gördü

 

[Korhan Ayhan]

Yoğun veride denediniz mi? Performans nasıl?

 

[bebar]

çok başarılı 30-40 dk beklediğim veri max 1 dk falan geliyor

 

[bebar]

Hocam sizden birşey daha istesem.
aynı çalışma sayfam içinde bir tablo daha var. O tablo içinde bulunan bir veriyi asıl tabloma aynı hızla yazdırmam mümkün müdür?
Örnek tablo ekledim orada detaylı anlatmaya çalıştım.
Desteğiniz için çok teşekkür ederim.

 

[Ziynettin]

Sub yeni()
Z = TimeValue(Now)
Set dc1 = CreateObject("scripting.dictionary")
a = Range("Q4:T" & Cells(Rows.Count, "Q").End(3).Row).Value
For i = 1 To UBound(a)
    krt = a(i, 1) & "|" & a(i, 2) & "|" & a(i, 3)
        dc1(krt) = a(i, 4)
Next i
a = Range("B3:F" & Cells(Rows.Count, 2).End(3).Row).Value
ReDim b(1 To UBound(a), 1 To 1)
For i = 1 To UBound(a)
    krt = a(i, 1) & "|" & a(i, 2) & "|" & a(i, 5)
    If dc1.exists(krt) Then
        b(i, 1) = dc1(krt)
    End If
Next i
[L3].Resize(UBound(a)) = b
MsgBox CDate(TimeValue(Now) - Z), vbInformation
End Sub

 

[bebar]

Sub yeni()
Z = TimeValue(Now)
Set dc1 = CreateObject("scripting.dictionary")
a = Range("Q4:T" & Cells(Rows.Count, "Q").End(3).Row).Value
For i = 1 To UBound(a)
    krt = a(i, 1) & "|" & a(i, 2) & "|" & a(i, 3)
        dc1(krt) = a(i, 4)
Next i
a = Range("B3:F" & Cells(Rows.Count, 2).End(3).Row).Value
ReDim b(1 To UBound(a), 1 To 1)
For i = 1 To UBound(a)
    krt = a(i, 1) & "|" & a(i, 2) & "|" & a(i, 5)
    If dc1.exists(krt) Then
        b(i, 1) = dc1(krt)
    End If
Next i
[L3].Resize(UBound(a)) = b
MsgBox CDate(TimeValue(Now) - Z), vbInformation
End Sub

Ya sen nasıl bir kralsın