Sumproduct VBA

B

brownti

I have the following code to sum cells by cell color, however i need to take
it one step further by using sum product by cell color. i would like to sum
the numbers in the colored cells and then multiply by other cells that dont
have to have a specific color. can someone please help me out? Thanks
Function ColorFunction(rColor As Range, rRange As Range, Optional SUM As
Boolean)
Dim rCell As Range
Dim lCol As Long
Dim vResult

''''''''''''''''''''''''''''''''''''''
'Written by Ozgrid Business Applications
'www.ozgrid.com
'Sums or counts cells based on a specified fill color.
'''''''''''''''''''''''''''''''''''''''
lCol = rColor.Interior.ColorIndex
If SUM = True Then
For Each rCell In rRange
If rCell.Interior.ColorIndex = lCol Then
vResult = WorksheetFunction.SUM(rCell, vResult)
End If
Next rCell
Else
For Each rCell In rRange
If rCell.Interior.ColorIndex = lCol Then
vResult = 1 + vResult
End If
Next rCell
End If

ColorFunction = vResult
End Function
 
R

RadarEye

Hi Brownti

If I understand you corredtly this should do the trick
I created it with Excel 2003.

Public Function ColorSumProduct(rColor As Range, _
rMatch As Range, _
rProduct As Range) As Double
Dim dblResult As Double
Dim lngRows As Long
Dim lngCols As Long
Dim lngRL As Long
Dim lngCL As Long
Dim lngColor As Long

On Local Error GoTo ColorSumProduct_err

lngColor = rColor.Interior.Color
lngRows = rMatch.Rows.Count
lngCols = rMatch.Columns.Count

For lngRL = 1 To lngRows
For lngCL = 1 To lngCols
If rMatch.Cells(lngRL, lngCL).Interior.Color = lngColor
Then
dblResult = dblResult + _
(rMatch.Cells(lngRL, lngCL).Value * _
rProduct.Cells(lngRL, lngCL).Value)
End If
Next
Next

ColorSumProduct = dblResult

Exit Function
ColorSumProduct_err:
Debug.Print Err.Description
End Function

HTH,

Wouter
 
B

brownti via OfficeKB.com

That does the trick! Thanks a ton!
Hi Brownti

If I understand you corredtly this should do the trick
I created it with Excel 2003.

Public Function ColorSumProduct(rColor As Range, _
rMatch As Range, _
rProduct As Range) As Double
Dim dblResult As Double
Dim lngRows As Long
Dim lngCols As Long
Dim lngRL As Long
Dim lngCL As Long
Dim lngColor As Long

On Local Error GoTo ColorSumProduct_err

lngColor = rColor.Interior.Color
lngRows = rMatch.Rows.Count
lngCols = rMatch.Columns.Count

For lngRL = 1 To lngRows
For lngCL = 1 To lngCols
If rMatch.Cells(lngRL, lngCL).Interior.Color = lngColor
Then
dblResult = dblResult + _
(rMatch.Cells(lngRL, lngCL).Value * _
rProduct.Cells(lngRL, lngCL).Value)
End If
Next
Next

ColorSumProduct = dblResult

Exit Function
ColorSumProduct_err:
Debug.Print Err.Description
End Function

HTH,

Wouter
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Top