Topla Çarpım Formülü Makro İle

[baydeniro]

Merhaba arkadaşlar. Topla.Çarpım formülünün makro ile kullanımı daha mı hızlıdır acaba ? Ekteki dosyada datadaki veriler belli kriterlere göre toplayan Topla.Çarpım formülü var. Bu formül sonucunu makro ile elde etmek mümkün müdür ?

 

[Orion1]

En hızlısını yaptım.
Dosyanız ektedir.

Sub toplamlarterarsiz59()
Dim list(), i, z, ilk As Date, son As Date, iade
Application.ScreenUpdating = False
Set z = CreateObject("Scripting.dictionary")
With Sheets("DATA")
    .Range("J7:K" & Rows.Count).ClearContents
    ilk = .Range("Q7").Value
    son = .Range("Q9").Value
    list = .Range("B2:H" & .Cells(Rows.Count, "B").End(xlUp).Row).Value
    For i = 1 To UBound(list)
        If list(i, 1) >= ilk And list(i, 1) <= son Then
            If list(i, 6) = "" Then
                miktar = 1
                Else
                miktar = list(i, 6)
            End If
            If UCase(Replace(Replace(list(i, 3), "i", "İ"), "ı", "I")) = "İADE" Then
                iade = -1
                Else
                iade = 1
            End If
            If Not z.exists(list(i, 7)) Then
                z.Add list(i, 7), list(i, 4) * miktar * iade
                Else
                z.Item(list(i, 7)) = z.Item(list(i, 7)) + (list(i, 4) * miktar * iade)
            End If
        End If
    Next i
    If z.Count > 0 Then
        .Range("J7").Resize(z.Count, 2) = Application.Transpose(Array(z.items, z.keys))
        Application.ScreenUpdating = True
        MsgBox "İşlem Tamamlandı." & vbLf & "evrengizlen@hotmail.com", _
        vbOKOnly + vbInformation, Application.UserName
    End If
End With
End Sub

 

[Murat OSMA]

En hızlısını yaptım.
Dosyanız ektedir.

:biggrin::hiho::hiho::hiho:

 

[Ömer]

Merhaba,

Bu da yazdığınız formülün kestirme yoldan gidişi olsun.

=TOPLA(($B$2:$B$60000>=$Q$7)*($B$2:$B$60000<=$Q$9)*($H$2:$H$60000=K7)*(($G$2:
 $G$60000="")+$G$2:$G$60000)*($E$2:$E$60000*(($D$2:$D$60000="Satış")*2-1)))

Dizi formülüdür.

Not: Formüllerin hızlı çalışması için dinamik alan kullanmaya özen gösteriniz. Ayrıca büyük tablolarda formül kullanıyorsanız, seçenekler bölümünden hesaplamayı "el ile" düzenleyerek, sonuçları görmek istediğiniz zaman F9 tuşunu ile hesaplama yapmanızı tavsiye ederim.

 

[baydeniro]

Sayın Orion1, ilginize teşekkürler. İadeleri negatif olarak, miktar kısmı boş olanları ise 1 olarak dikkate almalı. Çözüm hakikaten çok hızlı. Ufak bir revizyon ile mükemmel olacak. Çok teşekkürler.

 

[baydeniro]

Sayın Ömer çok teşekkür ederim. Bu şekilde bir formül çözümü olabileceğini düşünmemiştim. Bu çözüm de bir hayli işime yarayacak. Sağolun, var olun.

 

[baydeniro]

Sayın Orion1, ilginize teşekkürler. İadeleri negatif olarak, miktar kısmı boş olanları ise 1 olarak dikkate almalı. Çözüm hakikaten çok hızlı. Ufak bir revizyon ile mükemmel olacak. Çok teşekkürler.

 

[Ömer]

Sayın Orion1'in kodlarını aşağıdakilerle değiştirin.

Sub toplamlarterarsiz59()
Dim list(), i, z, [COLOR=blue]a, b,[/COLOR] ilk As Date, son As Date
Application.ScreenUpdating = False
Set z = CreateObject("Scripting.dictionary")
With Sheets("DATA")
    .Range("J7:K" & Rows.Count).ClearContents
    ilk = .Range("Q7").Value
    son = .Range("Q9").Value
    list = .Range("B2:H" & .Cells(Rows.Count, "B").End(xlUp).Row).Value
    For i = 1 To UBound(list)
        If list(i, 1) >= ilk And list(i, 1) <= son Then
 
[COLOR=blue]           a = list(i, 4): b = list(i, 6)[/COLOR]
[COLOR=blue]           If list(i, 3) = "İade" Then a = -list(i, 4)[/COLOR]
[COLOR=blue]           If list(i, 6) = "" Then b = 1[/COLOR]
            
            If Not z.exists(list(i, 7)) Then
                z.Add list(i, 7), [COLOR=blue]a [/COLOR]* [COLOR=blue]b[/COLOR]
                Else
                z.Item(list(i, 7)) = z.Item(list(i, 7)) + ([COLOR=blue]a[/COLOR] * [COLOR=blue]b[/COLOR])
            End If
        End If
    Next i
    If z.Count > 0 Then
        .Range("J7").Resize(z.Count, 2) = Application.Transpose(Array(z.items, z.keys))
        Application.ScreenUpdating = True
        MsgBox "İşlem Tamamlandı." & vbLf & "[EMAIL="evrengizlen@hotmail.com"]evrengizlen@hotmail.com[/EMAIL]", _
        vbOKOnly + vbInformation, Application.UserName
    End If
End With
End Sub

.

 

[baydeniro]

Sayın Ömer süper süper süper. Allah sizden ve sayın Orion1 den razı olsun, harika ötesi bir kod. Elleriniz dert yüzü görmesin, işiniz gücünüz rast gitsin. Sağlıcakla kalın.

 

[Orion1]

Sayın Orion1, ilginize teşekkürler. İadeleri negatif olarak, miktar kısmı boş olanları ise 1 olarak dikkate almalı. Çözüm hakikaten çok hızlı. Ufak bir revizyon ile mükemmel olacak. Çok teşekkürler.

Doayayı güncelledim.2 nolu mesajdan indirebi.lirsiniz.

 

[baydeniro]

Çok çok teşekkür ederim sayın Orion1. Sağlıcakla kalın. Allah sizleri başımzıdan eksik etmesin.