Microsoft 365 compter des couleurs et comparer [RESOLU]

[TheSly]

Bonjour tout le monde,

Je cherche actuellement le moyen de compter les couleurs des cases et en retour afficher la couleur la plus présente.
Je m'explique :
- j'ai 4 cases qui se suivent. Ces 4 cases peuvent avoir 5 couleurs différentes
- dans une 5ème case, je veux quelle prenne la couleur la plus présente sur les 4 précédentes
- S'il y a égalité sur le nombre de couleurs, je veux quelle prenne la couleur qui est considérée comme plus critique.
- voici mes 5 couleurs, de la moins critique à la plus critique : vert, bleu, jaune, orange, rouge

Je n'ai pas trouvé de formule intégrée à Excel qui permette de comparer ou compter des couleurs.
J'ai trouvé un script VBA sur le forum qui permet de compter le nombre de couleur, mais je ne suis pas assez bon en scripting pour l'adapter à mon besoin.

D'avance merci pour votre aide

 

[Compte Supprimé 979]

Bonjour TheSly,

Déposez votre fichier sur ce forum, nous adapterons son code

@+

 

[job75]

Bonsoir TheSky, bienvenue sur XLD, bonsoir Bruno,

Pour un 1er post c'est remarquable car le problème est très intéressant et très bien posé.

Voyez le fichier joint et la macro affectée au bouton :

Sub Tirage_couleurs()
Dim coul, ub%, d As Object, n%, ca%, maxi%
coul = Array(3, 44, 6, 8, 4) 'codes couleurs classés par criticité décroissante
ub = UBound(coul)
Set d = CreateObject("Scripting.Dictionary")
With [C4:G4] 'à adapter
    For n = 1 To .Count - 1
        ca = coul(Application.RandBetween(0, ub)) 'couleur aléatoire
        d(ca) = d(ca) + 1 'comptage
        .Cells(n).Interior.ColorIndex = ca
    Next
    maxi = Application.Max(d.items)
    For n = 0 To ub
        If d(coul(n)) = maxi Then .Cells(.Count).Interior.ColorIndex = coul(n): Exit For
    Next
End With
End Sub

A+

 

[job75]

Bonjour le forum,

On peut faire des statistiques sur la survenance des couleurs, par exemple avec 100 000 tirages :

Sub Tirage_couleurs()
Dim t#, Ntirage&, coul, ub%, resu&(), d As Object, tirage&, n%, ca%, maxi%
t = Timer
Ntirage = 100000 'à adapter
coul = Array(3, 44, 6, 8, 4) 'codes couleurs classés par criticité décroissante
ub = UBound(coul)
ReDim resu(ub)
Set d = CreateObject("Scripting.Dictionary")
With [C4:G4] 'à adapter
    For tirage = 1 To Ntirage
        d.RemoveAll 'RAZ
        For n = 1 To .Count - 1
            ca = coul(Application.RandBetween(0, ub)) 'couleur aléatoire
            d(ca) = d(ca) + 1 'comptage
            If tirage = Ntirage Then .Cells(n).Interior.ColorIndex = ca
        Next
        maxi = Application.Max(d.items)
        For n = 0 To ub
            If d(coul(n)) = maxi Then
                resu(n) = resu(n) + 1
                If tirage = Ntirage Then .Cells(.Count).Interior.ColorIndex = coul(n)
                Exit For
            End If
        Next
    Next tirage
End With
'---restitution---
For n = 0 To ub
    [J4].Offset(n) = resu(ub - n) / Ntirage
Next
MsgBox Format(Ntirage, "#,##0") & " tirages en " & Format(Timer - t, "0.00 \sec"), , "Statistiques"
End Sub

A+

 

[TheSly]

Bonjour Bruno, bonjour Job,
En fait, je crois que j'aurais du plus expliciter mon besoin, je crains de ne t'avoir fait faire un script plus compliqué que prévu
Mon fichier est déjà pré-remplit avec les couleurs. Il s'agit d'un fichier de reporting. Dans le 1er onglet, chaque mois possède max 4 couleurs (1 par semaine), le but est de résumer le mois dans un 2ème onglet avec la couleur dominante (ou la plus critique en cas d'égalité).
Je vous joins un exemple en PJ.

 

[job75]

je crains de ne t'avoir fait faire un script plus compliqué que prévu

Non c'est votre fichier qui est plus compliqué mais il est facile d'adapter la solution de mon post #3.

Voyez le fichier joint et cette macro dans le code de la feuille "par mois" :

Private Sub Worksheet_Activate()
Dim coul, ub%, d As Object, F As Worksheet, col%, n%, i%, ca%, maxi%
coul = Array(3, 44, 6, 8, 43) 'codes couleurs classés par criticité décroissante
ub = UBound(coul)
Set d = CreateObject("Scripting.Dictionary")
Set F = Feuil1 'CodeName de la feuille source
With F.[A1].CurrentRegion
    For col = 1 To .Columns.Count
        If F.Cells(1, col) <> "" Then
            d.RemoveAll 'RAZ
            n = n + 1
            For i = 0 To F.Cells(1, col).MergeArea.Count - 1
                ca = F.Cells(3, col + i).Interior.ColorIndex 'couleur appliquée en ligne 3
                d(ca) = d(ca) + 1 'comptage
            Next i
            maxi = Application.Max(d.items)
            For i = 0 To ub
                If d(coul(i)) = maxi Then Cells(2, n).Interior.ColorIndex = coul(i): Exit For
            Next i
        End If
    Next col
End With
End Sub

Elle se déclenche quand on active la feuille.

 

[TheSly]

Wahou !!!
C'est exactement ça qu'il me fallait !!! Ca me déconcerte toujours cette rapidité à scripter
Est-ce que tu peux juste me dire ce que je dois rajouter pour que le script prenne en compte les ligne qui suivent STP? J'en ai une petite quarantaine.

Merci beaucoup pour ta réponse !!!!!

 

[job75]

Il faut ajouter une boucle (lig) pour parcourir les lignes du UsedRange :

Private Sub Worksheet_Activate()
Dim coul, ub%, d As Object, F As Worksheet, col%, n%, lig&, i%, ca%, maxi%
coul = Array(3, 44, 6, 8, 43) 'codes couleurs classés par criticité décroissante
ub = UBound(coul)
Set d = CreateObject("Scripting.Dictionary")
Set F = Feuil1 'CodeName de la feuille source
Application.ScreenUpdating = False
Rows("2:" & Rows.Count).Interior.ColorIndex = xlNone 'RAZ
With F.[A1].CurrentRegion
    For col = 1 To .Columns.Count
        If F.Cells(1, col) <> "" Then
            n = n + 1
            For lig = 3 To F.UsedRange.Rows.Count
                d.RemoveAll 'RAZ
                For i = 0 To F.Cells(1, col).MergeArea.Count - 1
                    ca = F.Cells(lig, col + i).Interior.ColorIndex 'couleur appliquée en ligne lig
                    d(ca) = d(ca) + 1 'comptage
                Next i
                maxi = Application.Max(d.items)
                For i = 0 To ub
                    If d(coul(i)) = maxi Then Cells(lig - 1, n).Interior.ColorIndex = coul(i): Exit For
            Next i, lig
        End If
    Next col
End With
End Sub

 

[TheSly]

Bonjour Job,

C'est super!
Un grand merci à toi Job

 

[LucasRo]

Sinon il existe la fonction Somme.Si.couleur

 

[job75]

Bonjour LucasRo, bienvenue sur XLD,

Mais pas terrible votre 1er post :

- vous n'avez pas lu la Charte du forum, on dit bonjour quand on entre

- la fonction Somme.Si.couleur serait de peu d'utilité ici.

A+

 

[TheSly]

Bonjour,

Je me permets de réouvrir cette discussion car j'aurai besoin d'une fonctionnalité complémentaire sur ce code.
Ma hiérarchie a fortement apprécié le fichier, mais elle voudrait faire apparaitre un pourcentage sur chaque mois en plus de la couleur.
Je m'explique:
- On souhaite pondérer la valeur de chaque couleur : vert = 100, bleu = 75, jaune = 50, orange = 25, rouge =0.
- Si par exemple en Août on a 2 verts et 2 jaunes :
100 +100 + 50 +50 = 300.
300 / 4 semaines = 75%.
il faut donc faire apparaitre 75% dans la case du mois d'Août
- Le score maximum étant 400 (100%) et le minimum 0 (0%)

Je vous refourni le code

Option Explicit

Private Sub Worksheet_Activate()
Dim coul, ub%, d As Object, F As Worksheet, col%, n%, lig&, i%, ca%, maxi%
coul = Array(3, 44, 6, 24, 43) 'codes couleurs classés par criticité décroissante
ub = UBound(coul)
Set d = CreateObject("Scripting.Dictionary")
Set F = Feuil1 'CodeName de la feuille source
Application.ScreenUpdating = False
Rows("2:" & Rows.Count).Interior.ColorIndex = xlNone 'RAZ
With F.[A1].CurrentRegion
    For col = 4 To .Columns.Count
        If F.Cells(1, col) <> "" Then
            n = n + 1
            For lig = 3 To F.UsedRange.Rows.Count
                d.RemoveAll 'RAZ
                For i = 0 To F.Cells(1, col).MergeArea.Count - 1
                    ca = F.Cells(lig, col + i).Interior.ColorIndex 'couleur appliquée en ligne lig
                    d(ca) = d(ca) + 1 'comptage
                Next i
                maxi = Application.Max(d.items)
                For i = 0 To ub
                    If d(coul(i)) = maxi Then Cells(lig - 1, n).Interior.ColorIndex = coul(i): Exit For
            Next i, lig
        End If
    Next col
End With
End Sub

je me suis aussi aperçu que certains mois étaient sur 5 semaines (Mai ou Juillet pour cette année par exemple). Est-ce que cela ne risque pas de fausser les résultats ? Etrangement cela fonctionne bien avec les couleurs

Exemple du fichier source avec les semaines

Exemple du résultat par mois (qui existe déjà)

D'avance merci pour votre aide (et j'espère avoir été compréhensible)