Comment établir des liens entre plusieurs listes de validation d'une même feuille et créer une hiérarchie ?

**101IT** · 22/05/2019, 21h41

Bonjour,

Je joins un classeur test afin d'illustrer clairement mon problème.
J'ai créé sur une feuille plusieurs listes de validation faisant références à une liste de produit. (Jusque là, c'est classique !)

Des “supports“, chez divers “fournisseurs“, catalogués suivant des noms de “matières“, des “formats“ et “épaisseurs“ !

Je ne parviens pas à éviter que les informations “inutiles“ dans une liste n'apparaissent lorsqu'un choix est établi dans l'une ou l'autre liste invariablement !

Je m'explique :
Si je sélectionne “Plaque“ dans la liste “Support“, et que ce support n'est pas distribué par le fournisseur “C“, alors “C“ ne devrait plus apparaitre dans la liste “Fournisseur“ !
En revanche, “Plaque“ étant distribué par “A“ et “B“, ils restent dans la liste de validation “Fournisseur“ et les différents “Formats“ et “Epaisseurs“ disponibles chez l'un ou l'autre également !

Idem pour les autres listes. Si je choisi d'abord une “matière“, la liste “Epaisseur“ ne devrait m'indiquer que les épaisseurs disponibles pour cette matière ou le fournisseur qui en dispose ...

J'ai tenté plusieurs tentatives notamment par le biais de la “Feuil3“.
J'ai laissé une des formules que j'ai testé (Voir Cellule E11) mais sans succès.

Au passage, j'ai constaté un second problème qui est peut-être lié au premier !
L'affichage du “Prix“ est correct lorsqu'on indique les valeurs qui correspondent à la première ligne de la “Liste produits“ mais ne fonctionne pas pour les autres ! (C'était pourtant le cas au début de mon développement)

Pourriez-vous m'aider ? Un oeil plus aguerri que le mien verra peut-être ce que je ne vois pas !

Inutile de s'attarder sur les éléments qui concernent les “Marges“ et “Taux“ et pourcentages ... ça n'a pas d'influence !

Merci d'avance
Classeur TEST.xlsx
101IT

**ARTURO83** · 23/05/2019, 08h45

Bonjour,

Code dans la feuille "CALCUL"

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
13
Private Sub Worksheet_Change(ByVal Target As Range)
    Application.EnableEvents = False
    If Target.Address = "$C$7" Then
        Liste_Fournisseur
    ElseIf Target.Address = "$C$8" Then
        Liste_Matiere
    ElseIf Target.Address = "$C$9" Then
        Liste_Format
    ElseIf Target.Address = "$C$10" Then
        Liste_Epaisseur
    End If
    Application.EnableEvents = True
End Sub

Code dans module 1

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
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
    Option Compare Text
 
Sub Liste_Fournisseur()
    Application.ScreenUpdating = False
    Set F1 = Sheets("CALCUL")
    Set f2 = Sheets("Liste produits")
 
    'Création liste des fournisseurs
    Support = F1.[C7]
    F1.Columns("L:O").ClearContents
    F1.[C8:C12].ClearContents
    Set D = CreateObject("Scripting.Dictionary")
    For Each c In f2.Range("A2:A" & f2.[A10000].End(xlUp).Row)
        If Not D.exists(c.Offset(, 3).Text) And c.Text = Support Then D(c.Offset(, 3).Text) = ""
    Next c
    If D.Count > 0 Then F1.[L1].Resize(D.Count) = Application.Transpose(D.Keys)
    DL = F1.[L100].End(xlUp).Row
    F1.Names.Add Name:="Liste1", RefersToR1C1:="=CALCUL!R1C12:R" & DL & "C12"
 
    F1.Range("C8").Select
    With Selection.Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="=Liste1"
        .IgnoreBlank = True
        .InCellDropdown = True
        .ShowInput = True
        .ShowError = True
    End With
    Set D = Nothing
    Set F1 = Nothing
    Set f2 = Nothing
End Sub
 
Sub Liste_Matiere()
    Application.ScreenUpdating = False
    Set F1 = Sheets("CALCUL")
    Set f2 = Sheets("Liste produits")
 
    'Création liste des matières
    Support = F1.[C7]
    Fournisseur = F1.[C8]
    F1.Columns("M:O").ClearContents
    F1.[C9:C12].ClearContents
    Set D = CreateObject("Scripting.Dictionary")
    For Each c In f2.Range("A2:A" & f2.[A10000].End(xlUp).Row)
        If Not D.exists(c.Offset(, 9).Text) And c.Text = Support And c.Offset(, 3).Text = Fournisseur Then D(c.Offset(, 9).Text) = ""
    Next c
    If D.Count > 0 Then F1.[M1].Resize(D.Count) = Application.Transpose(D.Keys)
    DL = F1.[M100].End(xlUp).Row
    F1.Names.Add Name:="Liste2", RefersToR1C1:="=CALCUL!R1C13:R" & DL & "C13"
 
    F1.Range("C9").Select
    With Selection.Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="=Liste2"
        .IgnoreBlank = True
        .InCellDropdown = True
        .ShowInput = True
        .ShowError = True
    End With
    Set D = Nothing
    Set F1 = Nothing
    Set f2 = Nothing
End Sub
 
Sub Liste_Format()
    Application.ScreenUpdating = False
    Set F1 = Sheets("CALCUL")
    Set f2 = Sheets("Liste produits")
 
    'Création liste des formats
    Support = F1.[C7]
    Fournisseur = F1.[C8]
    Matiere = F1.[C9]
    F1.Columns("N:O").ClearContents
    F1.[C10:C12].ClearContents
    Set D = CreateObject("Scripting.Dictionary")
    For Each c In f2.Range("A2:A" & f2.[A10000].End(xlUp).Row)
        If Not D.exists(c.Offset(, 6).Text) And c.Offset(, 3).Text = Fournisseur And c.Text = Support And _
        c.Offset(, 9).Text = Matiere Then D(c.Offset(, 6).Text) = ""
    Next c
    If D.Count > 0 Then F1.[N1].Resize(D.Count) = Application.Transpose(D.Keys)
    DL = F1.[N100].End(xlUp).Row
    F1.Names.Add Name:="Liste3", RefersToR1C1:="=CALCUL!R1C14:R" & DL & "C14"
 
    F1.Range("C10").Select
    With Selection.Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="=Liste3"
        .IgnoreBlank = True
        .InCellDropdown = True
        .ShowInput = True
        .ShowError = True
    End With
    Set D = Nothing
    Set F1 = Nothing
    Set f2 = Nothing
End Sub
 
Sub Liste_Epaisseur()
    Application.ScreenUpdating = False
    Set F1 = Sheets("CALCUL")
    Set f2 = Sheets("Liste produits")
 
    'Création liste des épaisseurs
    Support = F1.[C7]
    Fournisseur = F1.[C8]
    Matiere = F1.[C9]
    Formats = F1.[C10]
    F1.Columns("O:O").ClearContents
    F1.[C11:C12].ClearContents
    Set D = CreateObject("Scripting.Dictionary")
    For Each c In f2.Range("A2:A" & f2.[A10000].End(xlUp).Row)
        If Not D.exists(c.Offset(, 12).Text) And c.Offset(, 3).Text = Fournisseur And c.Text = Support And _
        c.Offset(, 9).Text = Matiere And c.Offset(, 6).Text = Formats Then D(c.Offset(, 12).Text) = ""
    Next c
    If D.Count > 0 Then F1.[O1].Resize(D.Count) = Application.Transpose(D.Keys)
    DL = F1.[O100].End(xlUp).Row
    F1.Names.Add Name:="Liste4", RefersToR1C1:="=CALCUL!R1C15:R" & DL & "C15"
 
    F1.Range("C11").Select
    With Selection.Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="=Liste4"
        .IgnoreBlank = True
        .InCellDropdown = True
        .ShowInput = True
        .ShowError = True
    End With
 
    'Formule du prix de vente
    F1.Range("C12").FormulaR1C1 = "=SUMPRODUCT(('Liste produits'!R[-10]C[-2]:R[1]C[-2]=R7C3)*('Liste produits'!R[-10]C[1]:R[1]C[1]=R8C3)*('Liste produits'!R[-10]C[7]:R[1]C[7]=R9C3)*('Liste produits'!R[-10]C[4]:R[1]C[4]=R10C3)*('Liste produits'!R[-10]C[10]:R[1]C[10]=R11C3),'Liste produits'!R[-10]C[13]:R[1]C[13])"
 
    Set D = Nothing
    Set F1 = Nothing
    Set f2 = Nothing
End Sub

Le fichier
Pièce jointe 477361

Cdlt

**101IT** · 23/05/2019, 11h04

Bonjour Arturo83,

Merci pour votre réponse détaillée.
Je ne suis pas vraiment expérimenté sur VBA, mais j'ai tout de même rapidement pu intégrer votre code dans le module1 et la Macro dans la feuille “Calcul“
Cependant, il m'affiche une erreur lors de l'exécution

- Erreur d'exécution “429“
Un composant ActiveX ne peut pas créer d'objet

Le problème se situe à cet endroit dans le code :

Code :

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

1
2
3
4
5
6
7
8
9
10
Sub Liste_Fournisseur()
    Application.ScreenUpdating = False
    Set F1 = Sheets("CALCUL")
    Set f2 = Sheets("Liste produits")
 
    'Création liste des fournisseurs
    Support = F1.[C7]
    F1.Columns("L:O").ClearContents
    F1.[C8:C12].ClearContents
    Set D = CreateObject("Scripting.Dictionary")

Pourriez-vous m'aider à résoudre ce point ?
Je suppose qu'ensuite la macro fonctionnera

Merci d'avance

101IT

**ARTURO83** · 24/05/2019, 08h52

Bonjour,

Je n'avais pas vu que vous étiez sur MAC:
problème: les contrôles activeX ne fonctionnent pas sous MAC, j'ai donc revu ma copie en espérant que cela fonctionne bien.

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
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
 
Option Compare Text
 
Sub Liste_Fournisseur()
    Application.ScreenUpdating = False
    Set f1 = Sheets("CALCUL")
    Set f2 = Sheets("Liste produits")
 
    'Création liste des fournisseurs
    Support = f1.[C7]
    f1.Columns("L:O").ClearContents
    f1.[C8:C12].ClearContents
 
    Dl_F2 = f2.[A100].End(xlUp).Row
    L = 1
    For i = 2 To Dl_F2
        If f2.Cells(i, "A") = Support Then
            If L = 1 Then
                f1.Cells(L, "L") = f2.Cells(i, "D")
                L = L + 1
            ElseIf L > 1 And f2.Cells(i, "D") <> f1.Cells(L - 1, "L") Then
                f1.Cells(L, "L") = f2.Cells(i, "D")
                L = L + 1
            End If
        End If
    Next i
    DL = f1.[L100].End(xlUp).Row
    f1.Range("L1:L" & DL).Sort [L1], 1
    f1.Names.Add Name:="Liste1", RefersToR1C1:="=CALCUL!R1C12:R" & DL & "C12"
 
    f1.Range("C8").Select
    With Selection.Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="=Liste1"
        .IgnoreBlank = True
        .InCellDropdown = True
        .ShowInput = True
        .ShowError = True
    End With
    Set f1 = Nothing
    Set f2 = Nothing
End Sub
 
Sub Liste_Matiere()
    Application.ScreenUpdating = False
    Set f1 = Sheets("CALCUL")
    Set f2 = Sheets("Liste produits")
 
    'Création liste des matières
    Support = f1.[C7]
    Fournisseur = f1.[C8]
    f1.Columns("M:O").ClearContents
    f1.[C9:C12].ClearContents
 
    Dl_F2 = f2.[A100].End(xlUp).Row
    L = 1
    For i = 2 To Dl_F2
        If f2.Cells(i, "A") = Support And f2.Cells(i, "D") = Fournisseur Then
            If L = 1 Then
                f1.Cells(L, "M") = f2.Cells(i, "J")
                L = L + 1
            ElseIf L > 1 And f2.Cells(i, "J") <> f1.Cells(L - 1, "M") Then
                f1.Cells(L, "M") = f2.Cells(i, "J")
                L = L + 1
            End If
        End If
    Next i
 
    DL = f1.[M100].End(xlUp).Row
    f1.Range("M1:M" & DL).Sort [M1], 1
    f1.Names.Add Name:="Liste2", RefersToR1C1:="=CALCUL!R1C13:R" & DL & "C13"
 
    f1.Range("C9").Select
    With Selection.Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="=Liste2"
        .IgnoreBlank = True
        .InCellDropdown = True
        .ShowInput = True
        .ShowError = True
    End With
    Set f1 = Nothing
    Set f2 = Nothing
End Sub
 
Sub Liste_Format()
    Application.ScreenUpdating = False
    Set f1 = Sheets("CALCUL")
    Set f2 = Sheets("Liste produits")
 
    'Création liste des formats
    Support = f1.[C7]
    Fournisseur = f1.[C8]
    Matiere = f1.[C9]
    f1.Columns("N:O").ClearContents
    f1.[C10:C12].ClearContents
 
    Dl_F2 = f2.[A100].End(xlUp).Row
    L = 1
    For i = 2 To Dl_F2
        If f2.Cells(i, "A") = Support And f2.Cells(i, "D") = Fournisseur And f2.Cells(i, "J") = Matiere Then
            If L = 1 Then
                f1.Cells(L, "N") = f2.Cells(i, "G")
                L = L + 1
            ElseIf L > 1 And f2.Cells(i, "G") <> f1.Cells(L - 1, "N") Then
                f1.Cells(L, "N") = f2.Cells(i, "G")
                L = L + 1
            End If
        End If
    Next i
    DL = f1.[N100].End(xlUp).Row
    f1.Range("N1:N" & DL).Sort [N1], 1
    f1.Names.Add Name:="Liste3", RefersToR1C1:="=CALCUL!R1C14:R" & DL & "C14"
 
    f1.Range("C10").Select
    With Selection.Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="=Liste3"
        .IgnoreBlank = True
        .InCellDropdown = True
        .ShowInput = True
        .ShowError = True
    End With
    Set f1 = Nothing
    Set f2 = Nothing
End Sub
 
Sub Liste_Epaisseur()
    Application.ScreenUpdating = False
    Set f1 = Sheets("CALCUL")
    Set f2 = Sheets("Liste produits")
 
    'Création liste des épaisseurs
    Support = f1.[C7]
    Fournisseur = f1.[C8]
    Matiere = f1.[C9]
    Formats = f1.[C10]
    f1.Columns("O:O").ClearContents
    f1.[C11:C12].ClearContents
 
    Dl_F2 = f2.[A100].End(xlUp).Row
    L = 1
    For i = 2 To Dl_F2
        If f2.Cells(i, "A") = Support And f2.Cells(i, "D") = Fournisseur And f2.Cells(i, "J") = Matiere And f2.Cells(i, "G") = Formats Then
            If L = 1 Then
                f1.Cells(L, "O") = f2.Cells(i, "M")
                L = L + 1
            ElseIf L > 1 And f2.Cells(i, "M") <> f1.Cells(L - 1, "O") Then
                f1.Cells(L, "O") = f2.Cells(i, "M")
                L = L + 1
            End If
        End If
    Next i
    DL = f1.[O100].End(xlUp).Row
    f1.Range("O1:O" & DL).Sort [O1], 1
    f1.Names.Add Name:="Liste4", RefersToR1C1:="=CALCUL!R1C15:R" & DL & "C15"
 
    f1.Range("C11").Select
    With Selection.Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="=Liste4"
        .IgnoreBlank = True
        .InCellDropdown = True
        .ShowInput = True
        .ShowError = True
    End With
 
    'Formule du prix de vente
    f1.Range("C12").FormulaR1C1 = "=SUMPRODUCT(('Liste produits'!R[-10]C[-2]:R[1]C[-2]=R7C3)*('Liste produits'!R[-10]C[1]:R[1]C[1]=R8C3)*('Liste produits'!R[-10]C[7]:R[1]C[7]=R9C3)*('Liste produits'!R[-10]C[4]:R[1]C[4]=R10C3)*('Liste produits'!R[-10]C[10]:R[1]C[10]=R11C3),'Liste produits'!R[-10]C[13]:R[1]C[13])"
 
    Set f1 = Nothing
    Set f2 = Nothing
End Sub

Avec le fichier
Pièce jointe 477699

Cdlt

**101IT** · 28/05/2019, 14h37

Bonjour,

Déjà, un très grand merci pour vos recherches.

J'ai une nouvelle alerte après avoir changé le module.

Erreur d'execution 1004 “La méthode Sort de la classe Range à échoué“

J'ai d'abord essayé votre module VBA en laissant les Macros “Fournisseur“, “Matière“, “Format“ et “Epaisseur“ mais également en les supprimant et l'alerte est identique.

Malheureusement ce type d'alerte sort totalement de mes compétences. sans doute cela vous parle t-il plus ?

Bien à vous,

101IT

**ARTURO83** · 28/05/2019, 16h11

Bonjour,

Sur la ligne f1.Range("L1:L" & DL).Sort [L1], 1: Quelle est la valeur de DL au moment du plantage?

Rappel sur le principe employé:
-Quand on sélectionne le support, on crée la liste des "Fournisseurs" liée au support, cette liste est ajoutée en colonne L de la feuille CALCUL.
-Quand on sélectionne le Fournisseur, on crée la liste des "Matière" liée au Fournisseur , cette liste est ajoutée en colonne M de la feuille CALCUL.
-Quand on sélectionne le Format, on crée la liste des "Epaisseur" liée au Format , cette liste est ajoutée en colonne N de la feuille CALCUL.
-Quand on sélectionne l'épaisseur, le prix s'affiche en C12 de la feuille CALCUL. (extraction par formule Sommeprod)

Cdlt

**101IT** · 13/06/2019, 20h57

Bonjour Arturo83,

Merci pour vos explications.

Le principe fonctionne en effet, mais pas de manière autonome.
Je ne parviens pas à activer les macros. Je pense qu'il s'agit d'un ordre logique mais je ne parviens pas à le rétablir.

J'ai essayé de m'en sortir durant des heures mais j'avoue ne pas comprendre le problème.

Comme vous l'indiquiez, les valeurs s'affichent bien en colonne L, M et N de la feuille de calcul. mais seulement si j'exécute les macros l'une après l'autre en respectant les valeurs vrais.

Le prix correspond bien au choix indiqué mais si ensuite on modifie le format, la matière ou le fournisseur ... les valeurs ne se mettent pas à jour.
Seul la variable Epaisseur fonctionne lorsque toutes les valeurs en amont sont vraies !

Pour exemple :
Support=Plaque ; Fournisseur=B ; matière=plastique ; format=100/200 ; Epaisseur= 2, 3 ou 4 alors le résultat est correct.
Si je change le fournisseur=A le format 100/200 devrait disparaitre puisqu'il n'existe pas chez ce fournisseur.
Le problème est récurrent sur d'autres valeurs également.

J'ai cherché un peu partout là ou je peux comprendre un problème mais je sèche totalement.

Si vous pouvez m'aider, vous me sauvez.

Je joins la dernière version Test du fichier pour exemple.

Classeur TEST 2.xlsm

Merci beaucoup
101IT

**ARTURO83** · 14/06/2019, 05h53

Bonjour,

Pour que cela fonctionne, il y a une macro d'appel des autres macros qui se trouve dans le module de la feuille "CALCUL", et celle-là, vous avez oublié de la recopier.

Voici la macro manquante dans le module de la feuille "CALCUL"

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
13
Private Sub Worksheet_Change(ByVal Target As Range)
    Application.EnableEvents = False
    If Target.Address = "$C$7" Then
        Liste_Fournisseur
    ElseIf Target.Address = "$C$8" Then
        Liste_Matiere
    ElseIf Target.Address = "$C$9" Then
        Liste_Format
    ElseIf Target.Address = "$C$10" Then
        Liste_Epaisseur
    End If
    Application.EnableEvents = True
End Sub

je vous retourne votre fichier avec la macro manquante
Pièce jointe 483358

Cdlt

**101IT** · 11/07/2019, 19h13

Bonjour,

Merci pour votre aide. Le fichier fonctionne désormais !

J'ai toutefois eu un peu de mal à corriger quelques derniers éléments dans les formules finales et également éviter le plantage lorsqu'on redémarre le fichier.

Par contre, impossible d'accélérer le processus qui est très lent même avec un minimum de données.

J'ai d'abord limité le nombre de ligne de traitement à 10 mais ça ne change rien avec les 10000 actuellement traitées... ça reste lent !

Je joins la dernière version avec les corrections

Auriez-vous une solution ?

Cordialement

101IT

**101IT** · 11/07/2019, 23h23

Re bonjour,

J'ai encore fait quelques corrections pour tenter d'accélérer le processus mai je ne vois pas vraiment de changement radical.

Je pense avoir un peu avancer sur le fichier exemple, mais celui-ci contient seulement quelques lignes et n'est toujours pas très rapide.

J'ai bien peur qu'en situation réelle avec des milliers de lignes le système n'avance plus du tout.

Je m'interroge donc sur la méthode pour parvenir à ce procédé ! Est-ce bien la bonne idée de passer par VBA pour quelque chose qui me parait assez simple au final ??

Si vous avez d'autres idées si on ne parviens pas à corriger ce code, je suis partant !

Merci Beaucoup

101IT

**ARTURO83** · 12/07/2019, 06h44

Bonjour,

La lenteur vient de la taille de la feuille "Liste produits", on s'en aperçoit très vite lors du déplacement de l'ascenseur vertical dans cette feuille.
Pour y remédier, j'ai créé une autre feuille "Liste produits" et recopié les données de la l'ancienne feuille, et uniquement les données, pas la feuille entière, depuis ça va beaucoup mieux.

Pièce jointe 490589

Cdlt

Comment établir des liens entre plusieurs listes de validation d'une même feuille et créer une hiérarchie ?

Excel

Discussions similaires

Partager

Partager