Bonjour, je veux créer une liste déroulante, mais j'ai un bug dans mon code ci-dessous que je n'arrive pas à débugger.
En effet, j'ai écrit 2 codes différents pour l’automatisation d'une liste déroulante mais même galère.
La première c'est propriété ou méthodes non gérées par cet objet
Le second code, se trouve voption, il est défini comme string mais il ne lit pas au dela d'une certaine valeur. comment contourner cela?
Une Âme sensible pourra t elle me sortir de cette galère?
Merci par avance
second code
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
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356 ' mettre la macro pour générer les menus déroulants quand on click sur une ligne Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range) Dim nligne As Integer Dim ncol As Integer Dim head As String Dim flag_liste As Integer Dim i As Integer Dim j As Integer For i = 1 To 8 'attention ici i correspond à la colonne For j = 6 To 120 adressname = "$" & LetCol(i) & "$" & Str(j) adressname = Replace(adressname, " ", "") If Target.Address = adressname Then 'ajout de la colonne index 'création des menus déroulants nligne = j ncol = i head = Cells(2, ncol).Value flag_liste = verifliste(head) If flag_liste = 1 Then Call CreeMenuDeroulant(nligne, ncol, head) Else GoTo suivant End If End If suivant: Next j Next i ' Chargement des conditions d'essai ' Selon le cahier des charges: ' - si les huit premières colonnes sont renseignées alors on charge les conditions d'essai ' - sinon, on imprime un message d'erreur et on vide les cellules associées ' trouver la fonction qui convertit les entiers en lettres For i = 9 To 120 For j = 6 To 120 'attention, ici i -> colonne ' j -> ligne NomCol = LetCol(i) adressname2 = "$" & NomCol & "$" & Str(j) adressname2 = Replace(adressname2, " ", "") If Target.Address = adressname2 Then ' vérifier que les colones 1 à 8 sont remplies flag = 0 For icol = 1 To 8 If Cells(j, icol).Value <> "" Then flag = flag + 1 End If Next icol If flag = 8 Then ' on recopie les conditions de l'essai Call RempliEnduranceEssai(j, i) Else ' message d'erreur puis suppression de la ligne en cours MsgBox "Le moteur n'a pas été renseigné dans la base de données Nouvelles_saisies. Contacter l'administrateur des bases de données" MsgBox "incompatibilté entre l'effacement et la macro: à terminer" ' For icol = 1 To 8 ' Cells(j, icol).Delete ' Next icol End If End If Next j Next i End Sub Function LetCol(NoCol) LetCol = Split(Cells(1, NoCol).Address, "$")(1) End Function Sub CreeMenuDeroulant(nligne As Integer, ncol As Integer, head As String) ' tout d'abord il faut récupérer le nom associé à la colonne choisie Dim voption As String Dim ncolliste As Integer Dim tmp() As String Dim lignedebut As Integer premiere_ligne = 4 ' dans le fichier liste, le premier élément des listes déroulantes ' récupération de la colonne de la liste qui correspond. ncolliste = ColonneListe(head) Set xlliste = ThisWorkbook.Worksheets("BDD_Listes") Set xlecriture = ThisWorkbook.Worksheets("Nouvelles_saisies") PremierMotCle = xlliste.Cells(premiere_ligne, ncolliste).Value flag_indirect = 0 If ncolliste > 1 Then For icol = 1 To (ncolliste - 1) If xlliste.Cells(premiere_ligne, icol).Value = PremierMotCle Then flag_indirect = 1 End If Next icol End If If flag_indirect = 0 Then ' simple liste ' voption = CreeList(head) listcol = ColonneListe(head) lignedebut = 4 nlignes = ThisWorkbook.Worksheets("BDD_Listes").Range(ThisWorkbook.Worksheets("BDD_Listes").Cells(4, listcol), ThisWorkbook.Worksheets("BDD_Listes").Cells(4, listcol)).End(xlDown).Row ' ReDim tmp(nlignes - lignedebut) 'For i = 0 To (nlignes - lignedebut) ' tmp(i) = ThisWorkbook.Worksheets("BDD_Listes").Cells(i + 4, listcol).Value ' Next i ThisWorkbook.Sheets("Nouvelles_saisies").Activate Cells(nligne, ncol).Select With Selection.Validation .Delete .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="=" & ThisWorkbook.Worksheets("BDD_Listes").Range(ThisWorkbook.Worksheets("BDD_Listes").Cells(4, listcol), ThisWorkbook.Worksheets("BDD_Listes").Cells(nlignes, listcol)).adress .IgnoreBlank = True .InCellDropdown = True .InputTitle = head .ErrorTitle = "" .InputMessage = "" .ErrorMessage = "" .ShowInput = True .ShowError = True End With Else If xlecriture.Cells(nligne, ncol - 1).Value = "" Then MsgBox "Renseigner la case précédente" GoTo fin Else head = xlecriture.Cells(nligne, ncol - 1).Value voption = CreeListIndirecte(head, ncolliste) ThisWorkbook.Sheets("Nouvelles_saisies").Activate Cells(nligne, ncol).Select With Selection.Validation .Delete .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=voption .IgnoreBlank = True .InCellDropdown = True .InputTitle = head .ErrorTitle = "" .InputMessage = "" .ErrorMessage = "" .ShowInput = True .ShowError = True End With End If End If fin: End Sub Function ColonneListe(NomListe As String) 'récupération de la colone qui contient l'entete NomListe Dim ncol As Integer Dim listcol As Integer listcol = 0 Set wbk = ThisWorkbook Set Sh = wbk.Sheets("BDD_Listes") NomListe = Replace(NomListe, " ", "") With Selection For ncol = 1 To 150 Sh.Cells(2, ncol).WrapText = False tmp = Replace(Sh.Cells(2, ncol).Value, Chr(10), "") ' suppression des éventuels espaces résiduels tmp = Replace(tmp, " ", "") Sh.Cells(2, ncol).WrapText = True If tmp = NomListe Then listcol = ncol End If Next ncol If listcol = 0 Then MsgBox "Erreur, aucune liste ne correspond à la colonne sélectionnée" End If End With ColonneListe = listcol End Function Function CreeList(NomListe As String) As String 'cette fonction génère la liste des options d'une liste donnée 'exple pour la liste B elle va générer la chaîne de caractères "B1,B2,B3,B4,B5" 'récupération de la colone qui contient l'entete NomListe listcol = ColonneListe(NomListe) tmp = "" lignedebut = 4 nlignes = ThisWorkbook.Worksheets("BDD_Listes").Range(ThisWorkbook.Worksheets("BDD_Listes").Cells(4, listcol), ThisWorkbook.Worksheets("BDD_Listes").Cells(4, listcol)).End(xlDown).Row Dim tmp(nlignes - lignedebut) As String For i = 0 To (nlignes + lignedebut - 1) tmp(i) = ThisWorkbook.Worksheets("BDD_Listes").Cells(i, listcol).Value Next i 'tmp = tmp & ThisWorkbook.Worksheets("BDD_Listes").Cells(i, listcol).Value CreeList = Left(tmp, Len(tmp) - 1) End Function Function CreeListIndirecte(head As String, ncolliste As Integer) Dim tmp As String flag1 = 0 flag2 = 0 For i = 4 To 500 If flag1 = 0 And flag2 = 0 And ThisWorkbook.Worksheets("BDD_Listes").Cells(i, ncolliste).Value = head Then flag1 = 1 idebut = i + 1 End If If flag1 = 1 And flag2 = 0 And ThisWorkbook.Worksheets("BDD_Listes").Cells(i, ncolliste).Value = "" Then flag2 = 1 ifin = i - 1 End If Next i tmp = "" For i = idebut To ifin tmp = tmp & ThisWorkbook.Worksheets("BDD_Listes").Cells(i, ncolliste).Value & "," Next i CreeListIndirecte = Left(tmp, Len(tmp) - 1) End Function Function verifliste(head As String) As Integer Dim flag As Integer Set wbk = ThisWorkbook Set Sh = wbk.Sheets("BDD_Listes") head = Replace(head, " ", "") flag = 0 For i = 1 To 120 'suppression de la mise en forme automatique Sh.Cells(2, i).WrapText = False ' suppression des retours chariot tmp = Replace(Sh.Cells(2, i).Value, Chr(10), "") ' suppression des éventuels espaces résiduels tmp = Replace(tmp, " ", "") If tmp = head Then flag = 1 End If Sh.Cells(2, i).WrapText = True Next i verifliste = flag End Function Sub RempliEnduranceEssai(iligne As Integer, jcol As Integer) Dim Plage As Range Dim tbl() As Variant Dim CombinaisonChoisie() As Variant Dim lignerecuperee() As Variant Set xlendurance = ThisWorkbook.Sheets("BDD_Endurance_Essai") ' à remplacer par la feuille saisie: A FAIRE Set xlsaisie = ThisWorkbook.Sheets("Nouvelles_saisies") With xlendurance Set Plage = .Range("A1:DV" & .Range("A36650").End(xlUp).Row) End With tbl = Plage.Value nblignes = UBound(tbl, 1) nbcol = UBound(tbl, 2) ReDim CombinaisonChoisie(1 To 8) ReDim lignerecuperee(1 To 8) For icol = 1 To 8 CombinaisonChoisie(icol) = xlsaisie.Cells(iligne, icol).Value Next icol numero_ligne_retenue = "vide" For i = 1 To nblignes If tbl(i, 1) = CombinaisonChoisie(1) And tbl(i, 2) = CombinaisonChoisie(2) And tbl(i, 3) = CombinaisonChoisie(3) And tbl(i, 4) = CombinaisonChoisie(4) And tbl(i, 5) = CombinaisonChoisie(5) And tbl(i, 6) = CombinaisonChoisie(6) And tbl(i, 7) = CombinaisonChoisie(7) And tbl(i, 8) = CombinaisonChoisie(8) Then numero_ligne_retenue = i End If Next i If numero_ligne_retenue = "vide" Then MsgBox "La combinaison choisie ne correspond à aucun élément de la base de données endurance" Else With xlsaisie For num_col = 9 To 120 Cells(iligne, num_col).Value = xlendurance.Cells(numero_ligne_retenue, num_col).Value Next num_col End With End If End Sub
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
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342 ' mettre la macro pour générer les menus déroulants quand on click sur une ligne Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range) Dim nligne As Integer Dim ncol As Integer Dim head As String Dim flag_liste As Integer Dim i As Integer Dim j As Integer For i = 1 To 8 'attention ici i correspond à la colonne For j = 6 To 120 adressname = "$" & LetCol(i) & "$" & Str(j) adressname = Replace(adressname, " ", "") If Target.Address = adressname Then 'ajout de la colonne index 'création des menus déroulants nligne = j ncol = i head = Cells(2, ncol).Value flag_liste = verifliste(head) If flag_liste = 1 Then Call CreeMenuDeroulant(nligne, ncol, head) Else GoTo suivant End If End If suivant: Next j Next i ' Chargement des conditions d'essai ' Selon le cahier des charges: ' - si les huit premières colonnes sont renseignées alors on charge les conditions d'essai ' - sinon, on imprime un message d'erreur et on vide les cellules associées ' trouver la fonction qui convertit les entiers en lettres For i = 9 To 120 For j = 6 To 120 'attention, ici i -> colonne ' j -> ligne NomCol = LetCol(i) adressname2 = "$" & NomCol & "$" & Str(j) adressname2 = Replace(adressname2, " ", "") If Target.Address = adressname2 Then ' vérifier que les colones 1 à 8 sont remplies flag = 0 For icol = 1 To 8 If Cells(j, icol).Value <> "" Then flag = flag + 1 End If Next icol If flag = 8 Then ' on recopie les conditions de l'essai Call RempliEnduranceEssai(j, i) Else ' message d'erreur puis suppression de la ligne en cours MsgBox "Le moteur n'a pas été renseigné dans la base de données Nouvelles_saisies. Contacter l'administrateur des bases de données" MsgBox "incompatibilté entre l'effacement et la macro: à terminer" ' For icol = 1 To 8 ' Cells(j, icol).Delete ' Next icol End If End If Next j Next i End Sub Function LetCol(NoCol) LetCol = Split(Cells(1, NoCol).Address, "$")(1) End Function Sub CreeMenuDeroulant(nligne As Integer, ncol As Integer, head As String) ' tout d'abord il faut récupérer le nom associé à la colonne choisie Dim voption As String Dim ncolliste As Integer premiere_ligne = 4 ' dans le fichier liste, le premier élément des listes déroulantes ' récupération de la colonne de la liste qui correspond. ncolliste = ColonneListe(head) Set xlliste = ThisWorkbook.Worksheets("BDD_Listes") Set xlecriture = ThisWorkbook.Worksheets("Nouvelles_saisies") PremierMotCle = xlliste.Cells(premiere_ligne, ncolliste).Value flag_indirect = 0 If ncolliste > 1 Then For icol = 1 To (ncolliste - 1) If xlliste.Cells(premiere_ligne, icol).Value = PremierMotCle Then flag_indirect = 1 End If Next icol End If If flag_indirect = 0 Then ' simple liste voption = CreeList(head) ThisWorkbook.Sheets("Nouvelles_saisies").Activate Cells(nligne, ncol).Select With Selection.Validation .Delete .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=voption .IgnoreBlank = True .InCellDropdown = True .InputTitle = head .ErrorTitle = "" .InputMessage = "" .ErrorMessage = "" .ShowInput = True .ShowError = True End With Else If xlecriture.Cells(nligne, ncol - 1).Value = "" Then MsgBox "Renseigner la case précédente" GoTo fin Else head = xlecriture.Cells(nligne, ncol - 1).Value voption = CreeListIndirecte(head, ncolliste) ThisWorkbook.Sheets("Nouvelles_saisies").Activate Cells(nligne, ncol).Select With Selection.Validation .Delete .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=voption .IgnoreBlank = True .InCellDropdown = True .InputTitle = head .ErrorTitle = "" .InputMessage = "" .ErrorMessage = "" .ShowInput = True .ShowError = True End With End If End If fin: End Sub Function ColonneListe(NomListe As String) 'récupération de la colone qui contient l'entete NomListe Dim ncol As Integer Dim listcol As Integer listcol = 0 Set wbk = ThisWorkbook Set Sh = wbk.Sheets("BDD_Listes") NomListe = Replace(NomListe, " ", "") With Selection For ncol = 1 To 150 Sh.Cells(2, ncol).WrapText = False tmp = Replace(Sh.Cells(2, ncol).Value, Chr(10), "") ' suppression des éventuels espaces résiduels tmp = Replace(tmp, " ", "") Sh.Cells(2, ncol).WrapText = True If tmp = NomListe Then listcol = ncol End If Next ncol If listcol = 0 Then MsgBox "Erreur, aucune liste ne correspond à la colonne sélectionnée" End If End With ColonneListe = listcol End Function Function CreeList(NomListe As String) As String 'cette fonction génère la liste des options d'une liste donnée 'exple pour la liste B elle va générer la chaîne de caractères "B1,B2,B3,B4,B5" Dim tmp As String 'récupération de la colone qui contient l'entete NomListe listcol = ColonneListe(NomListe) tmp = "" lignedebut = 4 nlignes = 500 For i = lignedebut To nlignes If ThisWorkbook.Worksheets("BDD_Listes").Cells(i, listcol).Value <> "" Then tmp = tmp & ThisWorkbook.Worksheets("BDD_Listes").Cells(i, listcol).Value & "," End If Next i CreeList = Left(tmp, Len(tmp) - 1) End Function Function CreeListIndirecte(head As String, ncolliste As Integer) Dim tmp As String flag1 = 0 flag2 = 0 For i = 4 To 500 If flag1 = 0 And flag2 = 0 And ThisWorkbook.Worksheets("BDD_Listes").Cells(i, ncolliste).Value = head Then flag1 = 1 idebut = i + 1 End If If flag1 = 1 And flag2 = 0 And ThisWorkbook.Worksheets("BDD_Listes").Cells(i, ncolliste).Value = "" Then flag2 = 1 ifin = i - 1 End If Next i tmp = "" For i = idebut To ifin tmp = tmp & ThisWorkbook.Worksheets("BDD_Listes").Cells(i, ncolliste).Value & "," Next i CreeListIndirecte = Left(tmp, Len(tmp) - 1) End Function Function verifliste(head As String) As Integer Dim flag As Integer Set wbk = ThisWorkbook Set Sh = wbk.Sheets("BDD_Listes") head = Replace(head, " ", "") flag = 0 For i = 1 To 120 'suppression de la mise en forme automatique Sh.Cells(2, i).WrapText = False ' suppression des retours chariot tmp = Replace(Sh.Cells(2, i).Value, Chr(10), "") ' suppression des éventuels espaces résiduels tmp = Replace(tmp, " ", "") If tmp = head Then flag = 1 End If Sh.Cells(2, i).WrapText = True Next i verifliste = flag End Function Sub RempliEnduranceEssai(iligne As Integer, jcol As Integer) Dim Plage As Range Dim tbl() As Variant Dim CombinaisonChoisie() As Variant Dim lignerecuperee() As Variant Set xlendurance = ThisWorkbook.Sheets("BDD_Endurance_Essai") ' à remplacer par la feuille saisie: A FAIRE Set xlsaisie = ThisWorkbook.Sheets("Nouvelles_saisies") With xlendurance Set Plage = .Range("A1:DV" & .Range("A36650").End(xlUp).Row) End With tbl = Plage.Value nblignes = UBound(tbl, 1) nbcol = UBound(tbl, 2) ReDim CombinaisonChoisie(1 To 8) ReDim lignerecuperee(1 To 8) For icol = 1 To 8 CombinaisonChoisie(icol) = xlsaisie.Cells(iligne, icol).Value Next icol numero_ligne_retenue = "vide" For i = 1 To nblignes If tbl(i, 1) = CombinaisonChoisie(1) And tbl(i, 2) = CombinaisonChoisie(2) And tbl(i, 3) = CombinaisonChoisie(3) And tbl(i, 4) = CombinaisonChoisie(4) And tbl(i, 5) = CombinaisonChoisie(5) And tbl(i, 6) = CombinaisonChoisie(6) And tbl(i, 7) = CombinaisonChoisie(7) And tbl(i, 8) = CombinaisonChoisie(8) Then numero_ligne_retenue = i End If Next i If numero_ligne_retenue = "vide" Then MsgBox "La combinaison choisie ne correspond à aucun élément de la base de données endurance" Else With xlsaisie For num_col = 9 To 120 Cells(iligne, num_col).Value = xlendurance.Cells(numero_ligne_retenue, num_col).Value Next num_col End With End If End Sub
Partager