Hello
I want to multiply 2 columns based on several criteria i excel vba, using sumproduct, but I have difficulty getting it right.
I've tried building the code up bit by bit, but encounter several different problems. Either excel returns #NAME? or #VALUE!
At first I created a sumifs worksheetfunction, which works on one column, but when needing to multiply 2 or more columns I had to change it to a sumproduct function
Here is the sumif function, which works:
Here is my sumproduct function as it looks right now (last part of my code):
Sumact, kolonne1, kolonne2, kolonne3 and kolonne 4 are all ranges
my criterias are values in arrays
part of my problem is that the criteria for kolonne2 is only part of the string between ","
but I believe the main problem is my use of " and & and ( not beeing correct.
Here is the entire code:
I use excel2010 and windows 7 professional
Please help
Thanks
mlan1604
I want to multiply 2 columns based on several criteria i excel vba, using sumproduct, but I have difficulty getting it right.
I've tried building the code up bit by bit, but encounter several different problems. Either excel returns #NAME? or #VALUE!
At first I created a sumifs worksheetfunction, which works on one column, but when needing to multiply 2 or more columns I had to change it to a sumproduct function
Here is the sumif function, which works:
Code:
Application.WorksheetFunction.SumIfs(kolonne3, kolonne1, aUniqueArray_frugt(i), kolonne2, "*" & aUniqueArray_farve(a) & "*")
Here is my sumproduct function as it looks right now (last part of my code):
Code:
Sumact.Offset(0, 2).Value = Evaluate("SumProduct((" & kolonne1 & "=" & aUniqueArray_frugt(i) & ")*(" & kolonne2 & "=" & farve & ")*(" & kolonne3 & ") * (" & kolonne4 & "))")
Sumact, kolonne1, kolonne2, kolonne3 and kolonne 4 are all ranges
my criterias are values in arrays
part of my problem is that the criteria for kolonne2 is only part of the string between ","
but I believe the main problem is my use of " and & and ( not beeing correct.
Here is the entire code:
Code:
Sub GetProduct()
Code:
Dim Array_frugt()
Dim aUniqueArray_frugt() As String
Dim Array_farve()
Dim aUniqueArray_farve() As String
Dim Array_toemmer()
Dim lngCountFirst As Long
Dim lngCountUnique As Long
Dim bolFoundIt As Boolean
Dim strOne As String
Dim strTwo As String
Dim last_row As Integer
Dim irow As Integer
Dim Sumact As Range
Dim i As Integer
Dim a As Integer
Dim Ar As Range
Dim arow As Integer
Dim brow As Integer
Dim SearchString As String
Dim Br As Range
last_row = Range("A1").End(xlDown).Row
ReDim Array_frugt(last_row - 3)
ReDim Array_farve(last_row - 3)
ReDim Array_toemmer(last_row - 3)
'Storing values in the array
For i = 0 To last_row - 3
Array_frugt(i) = Range("B" & i + 3)
Array_farve(i) = Split(Range("C" & i + 3), ",")(1)
' Array_toemmer(i) = Application.WorksheetFunction.Product(Range("J" & i + 3), Range("E" & i + 3))
Next
' Finding unique values
' Find unikke værdier i kolonne A
ReDim aUniqueArray_frugt(0)
For lngCountFirst = LBound(Array_frugt()) To UBound(Array_frugt())
bolFoundIt = False
For lngCountUnique = LBound(aUniqueArray_frugt()) To UBound(aUniqueArray_frugt())
If aUniqueArray_frugt(lngCountUnique) = Array_frugt(lngCountFirst) Then
bolFoundIt = True
Exit For
End If
Next lngCountUnique
If Not bolFoundIt Then
aUniqueArray_frugt(UBound(aUniqueArray_frugt())) = Array_frugt(lngCountFirst)
ReDim Preserve aUniqueArray_frugt(UBound(aUniqueArray_frugt()) + 1)
End If
Next lngCountFirst
ReDim Preserve aUniqueArray_frugt(UBound(aUniqueArray_frugt()) - 1)
'''' Find unikke værdier i kolonne B
ReDim aUniqueArray_farve(0)
For lngCountFirst = LBound(Array_farve()) To UBound(Array_farve())
bolFoundIt = False
For lngCountUnique = LBound(aUniqueArray_farve()) To UBound(aUniqueArray_farve())
If aUniqueArray_farve(lngCountUnique) = Array_farve(lngCountFirst) Then
bolFoundIt = True
Exit For
End If
Next lngCountUnique
If Not bolFoundIt Then
aUniqueArray_farve(UBound(aUniqueArray_farve())) = Array_farve(lngCountFirst)
ReDim Preserve aUniqueArray_farve(UBound(aUniqueArray_farve()) + 1)
End If
Next lngCountFirst
ReDim Preserve aUniqueArray_farve(UBound(aUniqueArray_farve()) - 1)
' Setting up ranges and criteria for sumproduct
irow = 1
Set Ar = Columns("B").Find(What:="A", After:=Range("B1"), LookAt:=xlWhole, SearchDirection:=xlPrevious)
arow = Ar.Row + 1
Set Br = Columns("B").Find(What:="D*", After:=Range("B1"), LookAt:=xlWhole, SearchDirection:=xlPrevious)
brow = Br.Row
Set kolonne1 = ActiveSheet.Range("B" & arow & ":B" & brow)
Set kolonne2 = ActiveSheet.Range("C" & arow & ":C" & brow)
Set kolonne3 = ActiveSheet.Range("J" & arow & ":J" & brow)
Set kolonne4 = ActiveSheet.Range("E" & arow & ":E" & brow)
For a = 0 To UBound(aUniqueArray_farve())
For i = 0 To UBound(aUniqueArray_frugt())
'Only returning results <> 0. If then not working because of sumproduct, hense not active at this moment
'If Evaluate("SumProduct((" &kolonne1&"="&aUniqueArray_frugt(i)&")*("&kolonne2&"="&farve&")*("& kolonne3 & ") * ("& kolonne4 & "))") <> 0 Then
'pasting results in worksheet
Set Sumact = ActiveSheet.Range("N" & irow)
Sumact.Value = aUniqueArray_frugt(i)
Sumact.Offset(0, 1).Value = aUniqueArray_farve(a)
Sumact.Offset(0, 2).Value = Evaluate("SumProduct((" &kolonne1&"="&aUniqueArray_frugt(i)&")*("&kolonne2&"="&farve&")*("& kolonne3 & ") * ("& kolonne4 & "))")
irow = irow + 1
' End If
Next
Next
End Sub
I use excel2010 and windows 7 professional
Please help
Thanks
mlan1604