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

Auteurs : ,

Mots clefs associés à cette page : , , ,