Data and Color calculations

  • Thread starter Thread starter Ron
  • Start date Start date
R

Ron

I need to find a way to get total for a particular name. I
work in a vineyard and we want to track how many of each
vine we have. we have our rows and blocks of vines in a
spread sheet. I now have to sort by name then count how
many of each vine we have.


I also assign the vines a color based on when they will be
harvested. Can excel do the above type of calculation based
on sum or total of a particular color


Thanks so much for any help

Ron
redwards(at)ap.net
 
Hi Ron,

Try something like this modified to suit your ranges. Does not count
Conditional Formatting colors. Dave McRitchie has a site with a
professional example, but I have misplaced the site address.

Sub ColorCount()
'Counts the number of colored
'cells in a range named Data.
Dim Blue5 As Integer
Dim Red3 As Integer
Dim Green4 As Integer
Dim Yellow6 As Integer
Dim Cell As Range

For Each Cell In Range("Data") '("B1:F11")
If Cell.Interior.ColorIndex = 5 Then
Blue5 = Blue5 + 1
ElseIf Cell.Interior.ColorIndex = 3 Then
Red3 = Red3 + 1
ElseIf Cell.Interior.ColorIndex = 4 Then
Green4 = Green4 + 1
ElseIf Cell.Interior.ColorIndex = 6 Then
Yellow6 = Yellow6 + 1
End If
Next

Range("A1").Value = Blue5 & " Blue"
Range("A2").Value = Red3 & " Red"
Range("A3").Value = Green4 & " Green"
Range("A4").Value = Yellow6 & " Yellow"

MsgBox " You have: " & vbCr _
& vbCr & " Blue " & Blue5 _
& vbCr & " Red " & Red3 _
& vbCr & " Green " & Green4 _
& vbCr & " Yellow " & Yellow6, _
vbOKOnly, "CountColor"
End Sub

HTH
Regards,
Howard
 
Ron,

Counting by colour is not easy, but if you input the function supplied at
the end, you can do it with this formula

=SUMPRODUCT(--(ColorIndex(A1:A100)=3))

if you want the text colour, use

=SUMPRODUCT(--(ColorIndex(A1:A100,TRUE)=3))

You could also set another cell, say C1, to the colour red, and test like
this

=SUMPRODUCT(--(ColorIndex(A1:A100)=ColorIndex(C1)))

To include the name you could use, as an example,

=SUMPRODUCT((A1:A100="Vigonier")*(ColorIndex(A1:A100)=ColorIndex(C1)))

Here's the function

'---------------------------------------------------------------------
Function ColorIndex(rng As Range, _
Optional text As Boolean = False) As Variant
'---------------------------------------------------------------------
' Function: Returns the colorindex of the supplied range
' Synopsis:
' Author: Bob Phillips/Harlan Grove
'
'---------------------------------------------------------------------
Dim cell As Range, row As Range
Dim i As Long, j As Long
Dim iWhite As Long, iBlack As Long
Dim aryColours As Variant

If rng.Areas.Count > 1 Then
ColorIndex = CVErr(xlErrValue)
Exit Function
End If

iWhite = WhiteColorindex(rng.Worksheet.Parent)
iBlack = BlackColorindex(rng.Worksheet.Parent)

If rng.Cells.Count = 1 Then
If text Then
aryColours = DecodeColorIndex(rng, True, iBlack)
Else
aryColours = DecodeColorIndex(rng, False, iWhite)
End If

Else
aryColours = rng.Value
i = 0

For Each row In rng.Rows
i = i + 1
j = 0

For Each cell In row.Cells
j = j + 1

If text Then
aryColours(i, j) = DecodeColorIndex(cell, True, iBlack)
Else
aryColours(i, j) = DecodeColorIndex(cell, False, iWhite)
End If

Next cell

Next row

End If

ColorIndex = aryColours

End Function

Private Function WhiteColorindex(oWB As Workbook)
Dim iPalette As Long
WhiteColorindex = 0
For iPalette = 1 To 56
If oWB.Colors(iPalette) = &HFFFFFF Then
WhiteColorindex = iPalette
Exit Function
End If
Next iPalette
End Function

Private Function BlackColorindex(oWB As Workbook)
Dim iPalette As Long
BlackColorindex = 0
For iPalette = 1 To 56
If oWB.Colors(iPalette) = &H0 Then
BlackColorindex = iPalette
Exit Function
End If
Next iPalette
End Function

Private Function DecodeColorIndex(rng As Range, text As Boolean, idx As
Long)
Dim iColor As Long
If text Then
iColor = rng.font.ColorIndex
Else
iColor = rng.Interior.ColorIndex
End If
If iColor < 0 Then
iColor = idx
End If
DecodeColorIndex = iColor
End Function



--

HTH

Bob Phillips
... looking out across Poole Harbour to the Purbecks
(remove nothere from the email address if mailing direct)
 
Back
Top