Scripting.Dictionary ile ÇOKETOPLA

[ccuneyt13]

Sub CokEtopla ()

Dim s1 As Worksheet
Set s1 = Sheets("VERİ")
Set wf = Application.WorksheetFunction
Son = s1.Cells(s1.Rows.Count, "A").End(xlUp).Row

For i = 2 To Son

If s1.Range("BT" & i).value <> "" Then


If s1.Range("CC:CC").Count > 1 Then s1.Range("CD" & i) = wf.SumIfs(s1.Range("CC:CC"), s1.Range("H:H"), s1.Range("H" & i), s1.Range("BT:BT"), s1.Range("BT" & i), s1.Range("BU:BU"), s1.Range("BU" & i), s1.Range("BV:BV"), s1.Range("BV" & i)) Else s1.Range("CD" & i) = s1.Range("BT" & i)
End If

Next i
End Sub

Merhaba,
Yukarıdaki kod ile yapılan işlemi "Scripting.Dictionary" ile uyarlanması için kıymetli desteklerinizi rica edebilir miyim.

Normal formülümde bu.

=ÇOKETOPLA(CC:CC;H:H;H2;BT:BT;BT2;BU:BU;BU2;BV:BV;BV2)

Yukarıdaki kod işlemi yapıyor ama çok uzun sürüyor.
Aşağıdaki kendi gönderimde örneği var ama işin içinden çıkamadım.

Saygılar.

Merhaba,

"scripting.dictionary" metodu ile yapılan çalışma. Bu şekilde deneyiniz.

Sub topla()
Dim wT As Worksheet, wR As Worksheet
Dim a(), b(), c(), d As Object
Dim i As Long, deg As Variant
Set wT = Sheets("Transfer data")
Set wR = Sheets("Rapor")
Set d = CreateObject("scripting.dictionary")
Z = TimeValue(Now)

a = wR.Range("A2:G" & wR.Cells(Rows.Count, 1).End(3).Row).Value
    For i = 1 To UBound(a)
        deg = a(i, 1) & a(i, 2) & a(i, 3) & a(i, 4) & a(i, 6)
        d(deg) = d(deg) + CDbl(a(i, 7))
    Next i
  
    b = wT.Range("A2:G" & wT.Cells(Rows.Count, 1).End(3).Row).Value
    ReDim c(1 To UBound(b), 1 To 1)
    For i = 1 To UBound(b)
        deg = b(i, 1) & b(i, 2) & b(i, 6) & b(i, 3) & b(i, 7)
        c(i, 1) = CDbl(d(deg))
    Next i
  
    wT.[P2].Resize(UBound(b)) = c
  
MsgBox "İşlem tamam." & vbLf & vbLf & CDate(TimeValue(Now) - Z), vbCritical
End Sub

wT.[P2].Resize(UBound(b)) = c Veriler sonuç kontrolu için P sütununa yazdırıldı. Kırmızı yazılı yeri kendinize göre düzenlersiniz.

Stok transfer: dosya