Bonsoir à tous,

J’ai récupéré cette macro qui me serait utile et qui doit faire la somme de cellules de mêmes couleurs mais je ne sais pas l’utiliser !
Où faut-il la placer pour l’exécuter.
Je travaille avec Excel 1997-2003.
Merci beaucoup.




Private Sub Workbook_AddinInstall()
MainMenu
InitNomsCouleurs
End Sub

Private Sub Workbook_AddinUninstall()
DelMainMenu
End Sub

Private Sub Workbook_Open()
InitNomsCouleurs
End Sub


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_AddinInstall
'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

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
'renvoi 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

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

Configuration: Windows XP
Internet Explorer 6.0