Additionner suivant la couleur des cellules

Je voudrais sélectionner une couleur et additionner le contenu de cellules en fonction de la couleur sélectionnée.

Recopie le code joint dans un module standard. Puis exécute la procédure MainMenu.
Dans Excel, là où tu as des cellules de couleur à additionner, sélectionne une cellule puis clic droit. Choisis "Somme par couleur" puis la couleur qui t'intéresse puis la plage qui contient les cellules de la couleur choisie.
La fonction s'inscrit dans la cellule active, ses paramètres renseignés.
Tu peux aussi, bien sûr utiliser cette fonction depuis l'assistant fonction. La plage à examiner est facile à sélectionner avec l'assistant, mais pour la couleur, il te faudra prévoir une petite liste .

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

sub MainMenu()
'commande du menu contextuel des cellules
'exécuter une fois, ou mettre dans le Workbook_Open
'd'une macro complémentaire
Dim mCtrl As CommandBarPopup

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

end sub
Private sub AddCouleurs()
'ajoute à la commande du menu contextuel des cellules
'autant d'entrées qu'il y a de couleurs utilisées dans la feuille active
Dim mCtrl As CommandBarPopup, bCtrl As CommandBarButton

Set mCtrl = Application.CommandBars("Cell"). _
Controls("Somme par couleur")
 
For I = mCtrl.Controls.Count To 1 Step -1
mCtrl.Controls(I).Delete
Next
 
CouleursUtilisées
 
For I = LBound(tabCouleurs) To UBound(tabCouleurs)
With mCtrl.Controls.Add(msoControlButton)
.Caption = NomCouleur(tabCouleurs(I)) & " (" & tabCouleurs(I) & ")"
.FaceId = 2170
.OnAction = "'Compte """ & tabCouleurs(I) & """'"
End With
Next
 
'plus une pour détruire le menu si besoin
Set bCtrl = mCtrl.Controls.Add(msoControlButton)
With bCtrl
.Caption = "Détruire ce menu"
.FaceId = 3265
.BeginGroup = True
.OnAction = "DelMainMenu"
End With
 
end sub
sub Compte(IndexCouleur)
'procédure 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 = "Sélectionnez la plage qui contient" & vbLf
Msg = Msg & "les cellules de couleur '" & _
NomCouleur(CLng(IndexCouleur)) & "'" & vbLf
Msg = Msg & "que vous voulez additionner :"
 
'choix de la plage qui contient les cellules à sommer
On Error Resume Next
Set plage = Application.InputBox(Msg, "Somme par couleur", , , , , , 8)
If plage Is Nothing Then exit sub
'la cellule active ne doit pas être dans la plage examinée
If Not Intersect(plage, ActiveCell) Is Nothing Then
Msg = "La cellule active fait partie de la plage à examiner." & vbLf
Msg = Msg & "Risque de référence 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") = vbNo Then exit sub
End If

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

end sub

'pour faire la somme des cellules *sans* couleur, passer -4142 pour Couleur

Function SommeSelonCouleur(Plage_à_examiner As Range, _
Couleur_à_sommer As Long) As Double
'L Longre, mpfe
Dim Arr, I As Long, J As Integer
Application.Volatile True
Arr = Plage_à_examiner
For I = 1 To UBound(Arr, 1)
For J = 1 To UBound(Arr, 2)
If Plage_à_examiner(I, J).Interior.ColorIndex = _
Couleur_à_sommer Then
SommeSelonCouleur = SommeSelonCouleur + Arr(I, J)
End If
Next J
Next I
End Function
Private sub DelMainMenu()
'détruit la commande principale du menu contextuel des cellules
'(à mettre éventuellement dans l'événement Workbook_AddinUninstall
'd'une macro complémentaire)
On Error Resume Next
Application.CommandBars("Cell"). _
Controls("Somme par couleur").Delete
end sub

Traitements des tableaux globaux



Private Function NomCouleur(Idx) As String
'renvoie le nom de la couleur dans la palette d'Excel à partir de l'index
InitNomsCouleurs
For I = 1 To 41
If tabColors(I, 1) = Idx Then
NomCouleur = tabColors(I, 2)
Exit Function
End If
Next
End Function
Private sub CouleursUtilisées()
'remplit le tableau des couleurs utilisées dans la feuille active
'xlNone=-4142
Dim Vue As Boolean, I&, J&, cell As Range
Dim IdxCouleur&

I = 0
ReDim tabCouleurs(0)

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

tabCouleurs(I) = -4142

end sub

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

Ce mois-ci sur Excelabo

- Pas de nouvelle page.
- Pas de page modifiée