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

--
Message posted via OfficeKB.com
http://www.officekb.com/Uwe/Forums.a...mming/200811/1

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

That does the trick! Thanks a ton!

RadarEye wrote:
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

--
Message posted via OfficeKB.com
http://www.officekb.com/Uwe/Forums.a...mming/200811/1