XL 2016 Compter les cellules en fonction de la couleur issu du MFC

Rabeto · 19 Août 2021

Bonjour,

J'ai cherché une solution mais ce que j'ai trouvé ne correspond pas à ce que je souhaite avoir.
Si quelqu'un peut m'aider.

Je souhaite compter le nombre de cellule qui ont des couleurs issues d'une MEFC

job75 · 21 Août 2021

Bonjour Patrick, le forum,

Oui c'est moi qui avais la comprenette difficile

Alors avec le fichier de mon post #10 on utilisera 2 dictionary :

VB:

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...

natorp · 19 Août 2021

Bjr Rabeto

Avec ce lien de notre ami Jacques Boisgontier, tu trouveras ton bonheur :

Fonction sommeCouleurFond

Cordialement, Gérard

riton00 · 19 Août 2021

Voir cet essai

Pas oublier d'activer les macros pour un fonctionnement normal

Slts

Rabeto · 19 Août 2021

riton00 à dit:
Voir cet essai

Pas oublier d'activer les macros pour un fonctionnement normal

Slts

Merci 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?

Victor21 · 19 Août 2021

Bonjour @Rabeto
Le plus simple n'est-il pas de reprendre les conditions des mefc ?

Rabeto · 19 Août 2021

Victor21 à dit:
Bonjour @Rabeto
Le plus simple n'est-il pas de reprendre les conditions des mefc ?

Merci,

Oui, je vois,
mais si j'ajoute une colonne avec d'autre valeur, ça me comptabilise le tout, alors que je ne souhaite que les cellules colorées

Victor21 · 19 Août 2021

Re,
???
Si vous insérez une colonne avec des valeurs = ou > à 7, les mefc existantes s'appliqueront, et leur décompte s'ajustera. Rien que de très normal.
Vous l'auriez constaté si vous l'aviez testé
PS : idem en cas d'insertion de ligne(s)

natorp · 19 Août 2021

Bjr tout le monde

Bien vu Victor

Gérard

riton00 · 19 Août 2021

Bonjour,

Rabeto à dit:
Merci 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?

Si toujours partant pour retrouver le code couleur, alors voir Pj
Pas oublier d'activer les macros pour un fonctionnement normal

Slts

job75 · 19 Août 2021

Bonjour à tous,

Voyez le fichier joint et cette macro évènementielle dans le code de la feuille :

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

A+

job75 · 19 Août 2021

Ce fichier (2) est plus intéressant car on y liste les couleurs utilisées par les MFC :

VB:

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

Chris769375 · 20 Août 2021

job75 à dit:

Bonjour à tous,

Voyez le fichier joint et cette macro évènementielle dans le code de la feuille :

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

A+

Bonjour,

Est-il possible d'avoir en plus du message #10 la somme de toutes les cellules de couleur

Merci d'avance

job75 · 20 Août 2021

Bonjour,

Utilisez la fonction SOMME en A7.

A+

Chris769375 · 20 Août 2021

job75 à dit:
Bonjour,

Utilisez la fonction SOMME en A7.

A+

Aucune formule de A4 à A7 avec le fichier Nb couleur MFC(1).xlsm

job75 · 20 Août 2021

Comprenette difficile ? Entrez manuellement en A7 la formule =SOMME(A4:A6)

Nous parlons bien du fichier du post #10...

XL 2016 Compter les cellules en fonction de la couleur issu du MFC

Rabeto

XLDnaute Occasionnel

Pièces jointes

job75

natorp

XLDnaute Barbatruc

riton00

XLDnaute Impliqué

Pièces jointes

Rabeto

XLDnaute Occasionnel

Victor21

XLDnaute Barbatruc

Pièces jointes

Rabeto

XLDnaute Occasionnel

Victor21

XLDnaute Barbatruc

natorp

XLDnaute Barbatruc

riton00

XLDnaute Impliqué

Pièces jointes

job75

XLDnaute Barbatruc

Pièces jointes

job75

XLDnaute Barbatruc

Pièces jointes

Chris769375

XLDnaute Nouveau

job75

XLDnaute Barbatruc

Chris769375

XLDnaute Nouveau

job75

XLDnaute Barbatruc

Discussions similaires