' Règles de comptage et d'application des couleurs dans le Tableau14
' Fonctionne avec Tableau Structuré et Sans Tableau Structuré
' Ligne 1 (Titre) : Pas de couleur modifiée, ligne fixe.
' Ligne 2 et suivantes :
' --->> Ligne paire (ex : 2, 4, 6, ...) : Couleur par défaut de la feuille Excel (sans remplissage).
' --->> Ligne impaire (ex : 3, 5, 7, ...) : Couleur Bleu ciel léger (par défaut de la mise en forme du tableau).
'
' Option :
' --->> Couleur personnalisée par l'utilisateur :
' --->> Toute couleur ajoutée par l'utilisateur (ex : jaune, rouge) :
' * est prise en compte comme une couleur distincte pour cette cellule.
' * La couleur d'une cellule modifiée par l'utilisateur sur une ligne donnée
' * sera associée à l'entrée correspondante dans le comptage.
'
' Méthode d 'application :
' ----------------------
' --->> Parcourir les cellules du tableau pour compter les noms.
' --->> Identifier les couleurs par défaut et les couleurs personnalisées appliquées par l'utilisateur.
' --->> Générer un rapport sur le nombre total de noms et la couleur associée à chaque entrée.
Sub AnalyseNomsEtCouleursTableau14()
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets(1) ' Changez "Sheet1" en fonction du nom de votre feuille
' Plage du Tableau14 (F1:I11)
Dim tableauPlage As Range
Set tableauPlage = ws.Range("F2:I11") ' Exclu la ligne de titre
Dim dictNoms As Object
Set dictNoms = CreateObject("Scripting.Dictionary")
Dim couleurDict As Object
Set couleurDict = CreateObject("Scripting.Dictionary")
Dim CptColorDict As Object
Set CptColorDict = CreateObject("Scripting.Dictionary")
Dim cell As Range
Dim currentName As Variant
Dim rowIndex As Long
rowIndex = 2 ' Début de la ligne pour afficher les résultats
' Remplir le dictionnaire des noms et compter leurs occurrences
For Each cell In tableauPlage
currentName = cell.Value
' Compter le nombre d'occurrences
If Not dictNoms.exists(currentName) Then
dictNoms.Add currentName, 1
Else
dictNoms(currentName) = dictNoms(currentName) + 1
End If
' Vérifier les couleurs et les ajouter au dictionnaire des couleurs
If currentName <> "" And 16777215 <> cell.Interior.Color Then ' Couleur différente de la couleur par défaut (blanc)
If Not couleurDict.exists(currentName) Then
Set couleurDict(currentName) = CreateObject("Scripting.Dictionary")
End If
' Ajouter la couleur de fond de la cellule
If Not couleurDict(currentName).exists(cell.Interior.Color) Then
couleurDict(currentName).Add cell.Interior.Color, 1
CptColorDict.Add currentName, 1
Else
CptColorDict(currentName) = CptColorDict(currentName) + 1
End If
End If
Next cell
' Effacer le tableau existant (si nécessaire)
ws.Range("A1:C21").ClearContents
' Écrire les en-têtes dans la première ligne
ws.Cells(1, 1).Value = "Nom"
ws.Cells(1, 2).Value = "Nbr Total Nom"
ws.Cells(1, 3).Value = "Nbr Total Couleur"
' Remplir les résultats dans la plage A2:C21
For Each currentName In dictNoms.keys
If CptColorDict(currentName) > 0 Then
ws.Cells(rowIndex, 1).Value = currentName
ws.Cells(rowIndex, 2).Value = dictNoms(currentName) ' Nombre d'occurrences
ws.Cells(rowIndex, 3).Value = CptColorDict(currentName) ' Nombre de couleurs distinctes
rowIndex = rowIndex + 1
End If
Next currentName
End Sub
qui nous verra vieillir un jour de moins que la précédente (chouette non ?).
