Count coloured cells

[Francis Hookam]

Count coloured cells

Some months ago Bernard Ray gave me the functions repeated below and these
were used to good effect to sum the values in differently coloured cells
using the following:

=SUMBYCOLOR(R4C:R87C,CELLCOLORINDEX(RC,FALSE),FALSE)

I now need to count the number of cells (rather than the sum the values
within them) which are coloured within the range

Please show me how to change the functions, stored in the worksheet module,
to achieve this

Incidentally - is there any reason why these functions cannot be stored in
the Personal Macro Workbook, other than that the functions would not be
available on another computer? Would there be a clash if the functions were
held by chance in both Workbook Module and Personal Macro Workbook module?

Thank you

Francis Hookham

' This ColorIndex function returns the ColorIndex value of a the Interior
' (background) of a cell, or, if OfText is true, of the Font in the cell.
'
Function CellColorIndex(InRange As Range, Optional _
OfText As Boolean = False) As Integer

Application.Volatile True
If OfText = True Then
CellColorIndex = InRange(1, 1).Font.ColorIndex
Else
CellColorIndex = InRange(1, 1).Interior.ColorIndex
End If

End Function

' This SumByColor function return the SUM of the values of cells in
' InRange with a background color, or if OfText is True a
' font color, equal to WhatColorIndex.
'
Function SumByColor(InRange As Range, WhatColorIndex As Integer, _
Optional OfText As Boolean = False) As Double

Dim Rng As Range
Dim OK As Boolean

Application.Volatile True
For Each Rng In InRange.Cells
If OfText = True Then
OK = (Rng.Font.ColorIndex = WhatColorIndex)
Else
OK = (Rng.Interior.ColorIndex = WhatColorIndex)
End If
If OK And IsNumeric(Rng.Value) Then
SumByColor = SumByColor + Rng.Value
End If
Next Rng

End Function

 

[J Laroche]

Francis Hookam wrote on 2005/05/28 12:46:

Count coloured cells

Some months ago Bernard Ray gave me the functions repeated below and these
were used to good effect to sum the values in differently coloured cells
using the following:

=SUMBYCOLOR(R4C:R87C,CELLCOLORINDEX(RC,FALSE),FALSE)

I now need to count the number of cells (rather than the sum the values
within them) which are coloured within the range

.... snip

' This SumByColor function return the SUM of the values of cells in
' InRange with a background color, or if OfText is True a
' font color, equal to WhatColorIndex.
'
Function SumByColor(InRange As Range, WhatColorIndex As Integer, _
Optional OfText As Boolean = False) As Double

Dim Rng As Range
Dim OK As Boolean

Application.Volatile True
For Each Rng In InRange.Cells
If OfText = True Then
OK = (Rng.Font.ColorIndex = WhatColorIndex)
Else
OK = (Rng.Interior.ColorIndex = WhatColorIndex)
End If
If OK And IsNumeric(Rng.Value) Then
SumByColor = SumByColor + Rng.Value
End If
Next Rng

End Function

Instead of
SumByColor = SumByColor + Rng.Value
use
SumByColor = SumByColor + 1
in other words, the count of cells matching the conditions will increment by
one each time a cell is found.
By the way it would be good coding practice to put a
SumByColor = 0
before the For loop begins, to avoid unexpected values at the beginning. I
once searched long for a bug that appeared on a computer but not on another,
just because a boolean defaulted to True on one and False on another.

JL
Mac OS X 10.3.9, Office v.X 10.1.6

 

[Daniel CIZ]

Hi everyone

I have one macro for sum by color working on french computer. For eglish version you sh=
oud be able change "SommeSelonCouleur" par "SumByColor", as well as "IndexCouleur=
" ...and descriptions of colors (3 Rouge is 3 Red and so on..)

Its working as *.xla so you can have it in your Addins

How to use it:
You install the .xla and when you click with the right button you will find on the top of=
menu "Somme par couleur". you choose the area to sum and that is it.

PS: It's not working with conditionnal color formating

Public tabCouleurs, tabColors(1 To 41, 1 To 2)

Sub MainMenu()
'commande du menu contextuel des cellules
'ex=C3=A9cuter une fois, ou mettre dans le Workbook_AddinInstall
'd'une macro compl=C3=A9mentaire
Dim mCtrl As CommandBarPopup
=

Set mCtrl =3D Application.CommandBars("Cell"). _
Controls.Add(msoControlPopup, before:=3D1)
With mCtrl
.Caption =3D "Somme par couleur"
.OnAction =3D "AddCouleurs"
.BeginGroup =3D True
End With

End Sub

Private Sub AddCouleurs()
'ajoute =C3=A0 la commande du menu contextuel des cellules
'autant d'entr=C3=A9es qu'il y a de couleurs utilis=C3=A9es dans la feuille active=

Dim mCtrl As CommandBarPopup, bCtrl As CommandBarButton
=

Set mCtrl =3D Application.CommandBars("Cell"). _
Controls("Somme par couleur")
=

For I =3D mCtrl.Controls.Count To 1 Step -1
mCtrl.Controls(I).Delete
Next
=

CouleursUtilis=C3=A9es
=

For I =3D LBound(tabCouleurs) To UBound(tabCouleurs)
With mCtrl.Controls.Add(msoControlButton)
.Caption =3D NomCouleur(tabCouleurs(I)) & " (" & tabCouleurs(I) & ")"
.FaceId =3D 2170
.OnAction =3D "'Compte """ & tabCouleurs(I) & """'"
End With
Next
=

'plus une pour d=C3=A9truire le menu si besoin
Set bCtrl =3D mCtrl.Controls.Add(msoControlButton)
With bCtrl
.Caption =3D "Effacer ce menu"
.FaceId =3D 3265
.BeginGroup =3D True
.OnAction =3D "DelMainMenu"
End With

End Sub

Sub Compte(IndexCouleur)
'proc=C3=A9dure OnAction des commandes de chaque couleur
'la fonction de somme des cellules de la couleur choisie
'est inscrite dans la cellule active
Dim plage As Range, Msg$

Msg =3D "S=C3=A9lectionnez la plage qui contient" & vbLf
Msg =3D Msg & "les cellules de couleur '" & _
NomCouleur(CLng(IndexCouleur)) & "'" & vbLf
Msg =3D Msg & "que vous voulez additionner :"
=

'choix de la plage qui contient les cellules =C3=A0 sommer
On Error Resume Next
Set plage =3D Application.InputBox(Msg, "Somme par couleur", , , , , , 8)
If plage Is Nothing Then Exit Sub
=

'la cellule active ne doit pas =C3=AAtre dans la plage examin=C3=A9e
If Not Intersect(plage, ActiveCell) Is Nothing Then
Msg =3D "La cellule active fait partie de la plage =C3=A0 examiner." & vbLf
Msg =3D Msg & "Risque de r=C3=A9f=C3=A9rence circulaire. Abandon !"
MsgBox Msg, , "Somme par couleur"
Exit Sub
End If
=

'si la cellule active n'est pas libre
If Not IsEmpty(ActiveCell) Then
If MsgBox("La cellule active n'est pas vide. Continuer ?", vbYesNo, _
"Somme par couleur") =3D vbNo Then Exit Sub
End If
=

'renvoi de la formule dans la cellule active
ActiveCell.FormulaLocal =3D _
"=3DSommeSelonCouleur(" & plage.Address(0, 0) & ";" & CLng(IndexCouleur) & ")"
=

End Sub

'pour faire la somme des cellules *sans* couleur, passer -4142 pour Couleur
Function SommeSelonCouleur(Plage_=C3=A0_examiner As Range, _
Couleur_=C3=A0_sommer As Long) As Double
'L Longre, mpfe
Dim Arr, I As Long, J As Integer
Application.Volatile True
Arr =3D Plage_=C3=A0_examiner
For I =3D 1 To UBound(Arr, 1)
For J =3D 1 To UBound(Arr, 2)
If Plage_=C3=A0_examiner(I, J).Interior.ColorIndex =3D _
Couleur_=C3=A0_sommer Then
SommeSelonCouleur =3D SommeSelonCouleur + Arr(I, J)
End If
Next J
Next I
End Function

Sub DelMainMenu()
'd=C3=A9truit la commande principale du menu contextuel des cellules
'(=C3=A0 mettre =C3=A9ventuellement dans l'=C3=A9v=C3=A9nement Workbook_Addi=
nUninstall
'd'une macro compl=C3=A9mentaire)
On Error Resume Next
Application.CommandBars("Cell"). _
Controls("Somme par couleur").Delete
End Sub

'*****Traitements des tableaux globaux*****

Private Function NomCouleur(Idx) As String
'renvoi le nom de la couleur dans la palette d'Excel =C3=A0 partir de l'index
' InitNomsCouleurs
For I =3D 1 To 41
If tabColors(I, 1) =3D Idx Then
NomCouleur =3D tabColors(I, 2)
Exit Function
End If
Next
End Function

Private Sub CouleursUtilis=C3=A9es()
'remplit le tableau des couleurs utilis=C3=A9es dans la feuille active
'xlNone=3D-4142
Dim Vue As Boolean, I&, J&, cell As Range
Dim IdxCouleur&
=

I =3D 0
ReDim tabCouleurs(0)
=

For Each cell In ActiveSheet.UsedRange
If cell.Interior.ColorIndex <> -4142 Then
Vue =3D False
IdxCouleur =3D cell.Interior.ColorIndex
For J =3D LBound(tabCouleurs) To UBound(tabCouleurs)
If tabCouleurs(J) =3D IdxCouleur Then
Vue =3D True: Exit For
End If
Next
If Not Vue Then
tabCouleurs(I) =3D IdxCouleur
I =3D I + 1
ReDim Preserve tabCouleurs(I)
End If
End If
Next
=

tabCouleurs(I) =3D -4142
=

End Sub

Sub InitNomsCouleurs()
'remplit le tableau qui donne l'=C3=A9quivalence entre le ColorIndex
'et le nom de la couleur dans la palette d'Excel
tabColors(1, 1) =3D 1: tabColors(1, 2) =3D "Noir"
tabColors(2, 1) =3D 9: tabColors(2, 2) =3D "Rouge fonc=C3=A9"
tabColors(3, 1) =3D 3: tabColors(3, 2) =3D "Rouge"
tabColors(4, 1) =3D 7: tabColors(4, 2) =3D "Rose"
tabColors(5, 1) =3D 38: tabColors(5, 2) =3D "Rose saumon"
tabColors(6, 1) =3D 53: tabColors(6, 2) =3D "Marron"
tabColors(7, 1) =3D 46: tabColors(7, 2) =3D "Orange"
tabColors(8, 1) =3D 45: tabColors(8, 2) =3D "Orange clair"
tabColors(9, 1) =3D 44: tabColors(9, 2) =3D "Or"
tabColors(10, 1) =3D 40: tabColors(10, 2) =3D "Brun"
tabColors(11, 1) =3D 52: tabColors(11, 2) =3D "Vert olive"
tabColors(12, 1) =3D 12: tabColors(12, 2) =3D "Marron clair"
tabColors(13, 1) =3D 43: tabColors(13, 2) =3D "Citron vert"
tabColors(14, 1) =3D 6: tabColors(14, 2) =3D "Jaune"
tabColors(15, 1) =3D 36: tabColors(15, 2) =3D "Jaune clair"
tabColors(16, 1) =3D 51: tabColors(16, 2) =3D "Vert fonc=C3=A9"
tabColors(17, 1) =3D 10: tabColors(17, 2) =3D "Vert"
tabColors(18, 1) =3D 50: tabColors(18, 2) =3D "Vert marin"
tabColors(19, 1) =3D 4: tabColors(19, 2) =3D "Vert brillant"
tabColors(20, 1) =3D 35: tabColors(20, 2) =3D "Vert clair"
tabColors(21, 1) =3D 49: tabColors(21, 2) =3D "Bleu-vert fonc=C3=A9"
tabColors(22, 1) =3D 14: tabColors(22, 2) =3D "Bleu-vert"
tabColors(23, 1) =3D 42: tabColors(23, 2) =3D "Vert d'eau"
tabColors(24, 1) =3D 8: tabColors(24, 2) =3D "Turquoise"
tabColors(25, 1) =3D 34: tabColors(25, 2) =3D "Turquoise clair"
tabColors(26, 1) =3D 11: tabColors(26, 2) =3D "Bleu fonc=C3=A9"
tabColors(27, 1) =3D 5: tabColors(27, 2) =3D "Bleu"
tabColors(28, 1) =3D 41: tabColors(28, 2) =3D "Bleu clair"
tabColors(29, 1) =3D 33: tabColors(29, 2) =3D "Bleu ciel"
tabColors(30, 1) =3D 37: tabColors(30, 2) =3D "Bleu moyen"
tabColors(31, 1) =3D 55: tabColors(31, 2) =3D "Indigo"
tabColors(32, 1) =3D 47: tabColors(32, 2) =3D "Bleu-gris"
tabColors(33, 1) =3D 13: tabColors(33, 2) =3D "Violet"
tabColors(34, 1) =3D 54: tabColors(34, 2) =3D "Prune"
tabColors(35, 1) =3D 39: tabColors(35, 2) =3D "Lavande"
tabColors(36, 1) =3D 56: tabColors(36, 2) =3D "Gris-80%"
tabColors(37, 1) =3D 16: tabColors(37, 2) =3D "Gris-50%"
tabColors(38, 1) =3D 48: tabColors(38, 2) =3D "Gris-40%"
tabColors(39, 1) =3D 15: tabColors(39, 2) =3D "Gris-25%"
tabColors(40, 1) =3D 2: tabColors(40, 2) =3D "Blanc"
tabColors(41, 1) =3D -4142: tabColors(41, 2) =3D "(Aucune)"
End Sub