Instead formula SUMPRODUCT, I need a VBA solution

[motilulla]

Hello,

I am using the following SUMPRODUCT formula in the column N in the cell N6 to down

=SUMPRODUCT(--($D$6:$D$4108=J6)*--($E$6:$E$4108=K6)*--($F$6:$F$4108=L6))

As sample data it is shown only result for 10 rows J6:L15

			n1	n2	n3	n4	n5		n1	n2	n3		SUMAPRODUCTO
			4	12	24	27	36		1	4	10		2
			1	4	10	19	23		1	10	48		0
			14	15	28	35	40		1	6	13		4
			12	20	21	45	48		4	9	21		0
			1	10	12	16	48		4	46	48		0
			3	8	12	29	43		5	9	21		0
			12	37	39	40	50		27	38	48		0
			10	28	40	47	48		10	47	48		0
			3	7	25	45	50		14	15	35		0
			6	9	15	25	38		18	46	48		0
			5	9	19	21	38
			5	7	14	20	49
			2	8	17	32	50
			14	15	25	35	47
			5	9	20	21	26
			10	20	22	24	31
			4	9	15	21	47
			5	27	31	40	42
			1	6	13	30	49
			13	24	26	47	49
			18	23	37	46	48
			11	14	24	25	29
			3	7	12	26	34
			1	10	17	33	48
			5	6	11	30	44
			8	15	26	30	48
			10	22	27	38	48
			7	17	20	35	50
			1	10	44	45	48
			10	25	41	47	48
			6	8	27	37	41
			12	13	17	22	43
			5	19	31	43	50
			1	6	13	22	28
			20	21	27	33	40
			3	9	20	30	42
			10	15	17	40	45
			10	13	20	33	41
			1	6	13	17	26
			1	10	29	38	48
			5	8	14	22	32
			1	4	10	41	45
			7	12	27	38	48
			15	25	26	40	41
			18	28	39	46	48
			9	23	29	41	49
			1	6	13	15	16
			5	25	32	37	43
			3	18	22	27	32
			4	9	14	21	27
			4	8	11	19	46
			4	12	25	46	48
			2	19	24	26	49
			4	5	39	46	48

But my really data have 35000 rows so when I do formula copy from N6 till down to N35005 it freeze my computer

I tried to use it in the VBA as below but it does not work as it should

Sub Test_SUMPRODUCT()
    With Range("N6:N35005")
        .Formula = "=SUMPRODUCT(--($D$6:$D$59=J6)*--($E$6:$E$59=K6)*--($F$6:$F$59=L6))"
        .Value = .Value
    End With
End Sub

So far I need help can it is possible this could be done via VBA code, which can do the same job and leave the SUMPRODUCT values only

Thank you all.

I am using Excel 2000

Regards,
Moti

 

[mart37]

With the function EVALUATE you can retrieve the value of a formule.

 

[Anthony47]

After several trials I got good results using this code:

Sub SumProd()
Dim wOne, wTwo, oArr() As Long, myTim As Single
Dim I As Long, J As Long, K As Long, L As Long
Dim myDic As Object, myK As String, Result As String
'
Result = "P6"                   '<<< The starting position for results
Sheets("mySheet").Select        '<<< The sheet with the data
'
wOne = Range(Range("D6"), Range("D6").End(xlDown)).Resize(, 3).Value
wTwo = Range(Range("J6"), Range("J6").End(xlDown)).Resize(, 3).Value
ReDim oArr(1 To UBound(wTwo), 1 To 1)
myTim = Timer
Set myDic = CreateObject("Scripting.Dictionary")
For I = 1 To UBound(wOne)
    myK = wOne(I, 1) & "-" & wOne(I, 2) & "-" & wOne(I, 3)
    If myDic.Exists(myK) Then
        myDic.Item(myK) = myDic.Item(myK) + 1
    Else
        myDic.Add (myK), 1
    End If
Next I
For K = 1 To UBound(wTwo)
    myK = wTwo(K, 1) & "-" & wTwo(K, 2) & "-" & wTwo(K, 3)
    If myDic.Exists(myK) Then
        oArr(K, 1) = myDic.Item(myK)
    End If
Next K
Debug.Print Format(Timer - myTim, "0.00")
Range(Result).Resize(UBound(oArr) + 100, 1).ClearContents
Range(Result).Resize(UBound(oArr), 1) = oArr
Set myDic = Nothing
End Sub

The lines marked <<< needs to be customized according to the comment.

I assumed that the data are in D6:Hxxxx (the first block) and in J6:Lyyyy (the second block)

Put the code into a standard vbba module of your vba project, then run Sub SumProd

Try…

 

[motilulla]

After several trials I got good results using this code:

Sub SumProd()
Dim wOne, wTwo, oArr() As Long, myTim As Single
Dim I As Long, J As Long, K As Long, L As Long
Dim myDic As Object, myK As String, Result As String
'
Result = "P6"                   '<<< The starting position for results
Sheets("mySheet").Select        '<<< The sheet with the data
'
wOne = Range(Range("D6"), Range("D6").End(xlDown)).Resize(, 3).Value
wTwo = Range(Range("J6"), Range("J6").End(xlDown)).Resize(, 3).Value
ReDim oArr(1 To UBound(wTwo), 1 To 1)
myTim = Timer
Set myDic = CreateObject("Scripting.Dictionary")
For I = 1 To UBound(wOne)
    myK = wOne(I, 1) & "-" & wOne(I, 2) & "-" & wOne(I, 3)
    If myDic.Exists(myK) Then
        myDic.Item(myK) = myDic.Item(myK) + 1
    Else
        myDic.Add (myK), 1
    End If
Next I
For K = 1 To UBound(wTwo)
    myK = wTwo(K, 1) & "-" & wTwo(K, 2) & "-" & wTwo(K, 3)
    If myDic.Exists(myK) Then
        oArr(K, 1) = myDic.Item(myK)
    End If
Next K
Debug.Print Format(Timer - myTim, "0.00")
Range(Result).Resize(UBound(oArr) + 100, 1).ClearContents
Range(Result).Resize(UBound(oArr), 1) = oArr
Set myDic = Nothing
End Sub

The lines marked <<< needs to be customized according to the comment.

I assumed that the data are in D6:Hxxxx (the first block) and in J6:Lyyyy (the second block)

Put the code into a standard vbba module of your vba project, then run Sub SumProd

Try…

Anthony47, speechless VBA worked 100% perfect! And I got the results in a less than 1 second.

I do appreciate your help and time you spent to solve this as per request.

This is a second request please could you guide how can I change the data columns instead as now using D6+E6+F6, I want to use D6+F6+G6 (and the results columns will be remain the same)

Kind Regards
Moti

 

[Anthony47]

could you guide how can I change the data columns instead as now using D6+E6+F6, I want to use D6+F6+G6

Modify these two lines:

wOne = Range(Range("D6"), Range("D6").End(xlDown)).Resize(, 4).Value    'it now is Resize(,3)

myK = wOne(I, 1) & "-" & wOne(I, 3) & "-" & wOne(I, 4)                 'It is now I,2 and I,3

Bye

 

[motilulla]

Modify these two lines:

wOne = Range(Range("D6"), Range("D6").End(xlDown)).Resize(, 4).Value    'it now is Resize(,3)

myK = wOne(I, 1) & "-" & wOne(I, 3) & "-" & wOne(I, 4)                 'It is now I,2 and I,3

Bye

Anthony47, much kind of you fulfilling my both request, it is working like magic thank you for you time solving my requests.

Good Luck and nice start of the week ahead.

Kind Regards
Moti