Private Sub Worksheet_Change(ByVal Target As Range)
Dim d As Object, dd As Object, c As Range, coul&
Set d = CreateObject("Scripting.Dictionary")
Set dd = CreateObject("Scripting.Dictionary")
For Each c In [D3:M17] 'plage à adapter
coul = c.DisplayFormat.Interior.Color
d(coul) = d(coul) + 1 'comptage
dd(coul) = dd(coul) + Val(Replace(c, ",", ".")) 'somme
Next
Application.EnableEvents = False 'désactive les évènements
For Each c In [A4:A6] 'plage à adapter
coul = c.Interior.Color
c = "Nombre " & d(coul) & " - Somme " & Format(dd(coul), "0.00")
Next...
Merci pour votre retour,Voir cet essai
Pas oublier d'activer les macros pour un fonctionnement normal
Slts
Merci,Bonjour @Rabeto
Le plus simple n'est-il pas de reprendre les conditions des mefc ?
Si toujours partant pour retrouver le code couleur, alors voir PjMerci pour votre retour,
Comment avez vous trouver les numéros des couleurs, si par exemple je vais ajouter une autre cellules avec d'autre couleur, comment faire?
Private Sub Worksheet_Change(ByVal Target As Range)
Dim d As Object, c As Range, coul&
Set d = CreateObject("Scripting.Dictionary")
For Each c In [D3:M17] 'plage à adapter
coul = c.DisplayFormat.Interior.Color
d(coul) = d(coul) + 1 'comptage
Next
Application.EnableEvents = False 'désactive les évènements
For Each c In [A4:A6] 'plage à adapter
c = d(c.Interior.Color)
Next
Application.EnableEvents = True 'réactive les évènements
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim d As Object, c As Range, coul&, n&
Set d = CreateObject("Scripting.Dictionary")
For Each c In [D3:M17] 'plage à adapter
coul = c.DisplayFormat.Interior.Color
d(coul) = d(coul) + 1 'comptage
Next
'---restitution---
Application.ScreenUpdating = False
Application.EnableEvents = False 'désactive les évènements
If FilterMode Then ShowAllData 'si la feuille est filtrée
With [A4] '1ère cellule de destination, à adapter
n = d.Count
If n Then
.Resize(n) = Application.Transpose(d.keys) 'codes couleurs
For Each c In .Resize(n)
c.Interior.Color = c.Value 'colore
Next
.Resize(n) = Application.Transpose(d.items) 'nombres
End If
.Offset(n).Resize(Rows.Count - n - .Row + 1).Delete xlUp 'RAZ en dessous
End With
Application.EnableEvents = True 'réactive les évènements
End Sub
Bonjour,Bonjour à tous,
Voyez le fichier joint et cette macro évènementielle dans le code de la feuille :
A+VB:Private Sub Worksheet_Change(ByVal Target As Range) Dim d As Object, c As Range, coul& Set d = CreateObject("Scripting.Dictionary") For Each c In [D3:M17] 'plage à adapter coul = c.DisplayFormat.Interior.Color d(coul) = d(coul) + 1 'comptage Next Application.EnableEvents = False 'désactive les évènements For Each c In [A4:A6] 'plage à adapter c = d(c.Interior.Color) Next Application.EnableEvents = True 'réactive les évènements End Sub
Aucune formule de A4 à A7 avec le fichier Nb couleur MFC(1).xlsmBonjour,
Utilisez la fonction SOMME en A7.
A+