Discussion :

[bib34690]

Bonjour,

J'ai 1 liste des couleurs préférées par personne avec les colonnes nom, couleur1, couleur2.
Ex. :
Dupont; Bleu; jaune
Durant; jaune
...
Je voudrais avoir l'analyse des couleurs préférées dans 1 TCD.
Ex. :
Bleu; jaune
1;2

J'ai nommé ma col.1 "Couleur1" et je peut avoir l'analyse en glissant "Couleur1" ds le TCD.
J'ai essayé de nommer le range "B1:Cx" en "Couleurs" pour le glisser dans le TCD mais il n'apparait pas.

Existe t'il 1 solution ?

[Invité]

Bonjour,

Plutôt que d'utiliser un TCD, un tableau récapitulatif des couleurs alimenté par une fonction Nb.Si ne suffirait-il pas ?

Voir le vidage d'écran.

Couleur1 et Couleur2 sont des zones nommées correspondant à vos zones de saisie des couleurs.

Dans le tableau récapitulatif par couleur, chaque couleur est décomptée pour chaque zone nommée avec les formules

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

=NB.SI(Couleur1;A4) et =NB.SI(Couleur2;A4)

Au cas où vous auriez un nombre très important d'enregistrements et probablement aussi de couleurs, il faudrait alimenter ce tableau sur une autre feuille avec les macros suivantes :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
Public ShDecompte As Worksheet
 
Public Cellule As Range
Public CellulesCouleurs1 As Range
Public CellulesCouleurs2 As Range
 
 
 
 
Sub DecompterLesCouleurs()
 
Dim LigneDeTitre As Long
Dim DerniereLigne As Long
Dim ColonneDesDoublons As Long
 
Dim IncrementCouleur As Long
Dim I As Long
 
Dim ColonnesCouleurs As Variant
 
 
    Application.ScreenUpdating = False
 
    Set CellulesCouleurs1 = Sheets("Tableau des préférences").Range("Couleur1")
    Set CellulesCouleurs2 = Sheets("Tableau des préférences").Range("Couleur2")
    Set ShDecompte = Sheets("Décompte couleurs")
 
    ColonnesCouleurs = Array(CellulesCouleurs1, CellulesCouleurs2)
 
 
    Sheets("Décompte couleurs").Activate
    LigneDeTitre = 2
    ColonneDesDoublons = Cells(LigneDeTitre, ActiveSheet.Columns.Count).End(xlToLeft).Column + 1
 
 
    ' Effacement de la liste des couleurs actuelles
    Range(Cells(LigneDeTitre + 1, 1), Cells(ActiveSheet.Rows.Count, 5)).ClearContents
 
    ' Remplissage des couleurs dans la feuille Décompte
    IncrementCouleur = 1
 
    For I = 0 To 1
        For Each Cellule In ColonnesCouleurs(I)
            Select Case Cellule
                   Case Is <> ""
                        ShDecompte.Cells(LigneDeTitre + IncrementCouleur, 1) = Cellule
                        IncrementCouleur = IncrementCouleur + 1
            End Select
        Next Cellule
    Next I
 
    ' Tri des couleurs et suppression des doublons
    DerniereLigne = Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Row
 
    If DerniereLigne > LigneDeTitre Then
 
      Call SuppressionDesDoublons(LigneDeTitre, 1, ColonneDesDoublons)
 
    End If
 
    ' Mise en place des formules Nb.Si dans le tableau sur les lignes remplies
    DerniereLigne = Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Row
 
    If DerniereLigne > LigneDeTitre Then
 
        Range(Cells(LigneDeTitre + 1, 1), Cells(DerniereLigne, 1)).Select
 
        For Each Cellule In Selection
            Cellule.Offset(0, 1).FormulaR1C1 = "=COUNTIF(Couleur1,RC[-1])"
            Cellule.Offset(0, 2).FormulaR1C1 = "=COUNTIF(Couleur2,RC[-2])"
            Cellule.Offset(0, 3).FormulaR1C1 = "=RC[-2]+RC[-1]"
        Next Cellule
 
    End If
 
    Cells(LigneDeTitre, 1).Select
 
    Set ShDecompte = Nothing
    Set CellulesCouleurs1 = Nothing
    Set CellulesCouleurs2 = Nothing
 
    Application.ScreenUpdating = True
 
 
End Sub

Et pour supprimer les doublons

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
 
Sub SuppressionDesDoublons(LigneTitre As Long, ColonneATester As Long, ColonneDoublons As Long)
 
Dim DerniereLigne As Long
 
 
   DerniereLigne = Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Row
 
   ' Tri
   Range(Cells(LigneTitre, ColonneATester), Cells(DerniereLigne, ColonneATester)).Select
   Selection.Sort Key1:=Cells(LigneTitre, ColonneATester), Order1:=xlDescending, Header:=xlYes, _
                 OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
 
    '-------------------------------------------------------
    ' Mise en place de la formule pour détecter les doublons
    '-------------------------------------------------------
    Cells(LigneTitre + 1, ColonneDoublons).FormulaR1C1 = "=IF(RC[" & ColonneATester - ColonneDoublons & "]=R[-1]C[" & ColonneATester - ColonneDoublons & "],""Oui"","""")"
 
    Range(Cells(LigneTitre + 1, ColonneDoublons), Cells(DerniereLigne, ColonneDoublons)).Select
 
    With Selection
         .FillDown
         .Copy
         .PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    End With
 
    '-------------------------
    ' Suppression des doublons
    '-------------------------
 '   Range(Cells(LigneTitre + 1, ColonneDoublons), Cells(DerniereLigne, ColonneDoublons)).Select
    For Each Cellule In Selection
        If Cellule.Value = "Oui" Then Cellule.Offset(0, ColonneATester - ColonneDoublons).ClearContents
    Next Cellule
 
    '-----------------------------------
    ' Tri des lignes par ordre croissant
    '-----------------------------------
     Range(Cells(LigneTitre, ColonneATester), Cells(DerniereLigne, ColonneATester)).Select
    Selection.Sort Key1:=Cells(LigneTitre, ColonneATester), Order1:=xlAscending, Header:=xlYes, _
          OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
 
    ' Suppression des enregistrements dans la colonne Doublons
    Range(Cells(LigneTitre + 1, ColonneDoublons), Cells(DerniereLigne, ColonneDoublons)).ClearContents
 
End Sub

[bib34690]

J'espérais une simple astuce pour pouvoir utiliser le super TCD mais MS ne semble pas avoir prévu ce cas de figure.
Merci pour ce super boulot.