Listes en cascade

Version imprimable

Listes en cascade

Bonjour au Forum,
Dans une tentative de création de listes en cascades en adaptant un code, j'ai réussi à constituer la première liste. Les ennuis arrive dès la deuxième liste, qui ne se crée pas. A la ligne 33, le message d'erreur "L'indice n'appartient pas à la sélection" apparaît et me laisse dans l'incompréhension. Un peu d'aide sera la bienvenue.

Code:

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
Option Explicit
 
Dim f As Worksheet
Private Sub UserForm_Initialize()
Dim BD() As Variant
Dim Tbl() As Variant
Dim d As Variant
Dim i As Integer
 
  Set f = Sheets("test")
  Me.NoOrdre = f.Range("A" & Rows.Count).End(xlUp).Row
 
  Set f = Sheets("base")
  BD = f.Range("A2:C" & f.[B65000].End(xlUp).Row).Value
  Set d = CreateObject("Scripting.Dictionary")
  For i = 1 To UBound(BD)
    d(BD(i, 1)) = ""
  Next i
  Tbl = d.keys
  Tri Tbl, LBound(Tbl), UBound(Tbl)
  Me.Service.List = Tbl
 
End Sub
 
Private Sub Service_click()
Dim d As Variant
Dim i As Integer
Dim BD() As Variant
Dim Tbl As Variant
 
  Me.Fonction.Clear
  Set d = CreateObject("Scripting.Dictionary")
  For i = 1 To UBound(BD)
     If BD(i, 2) = Me.Service Then d(BD(i, 3)) = ""
  Next i
  Tbl = d.keys
  Tri Tbl, LBound(Tbl), UBound(Tbl)
  Me.Fonction.List = Tbl
End Sub
 
Private Sub Fonction_click()
Dim i As Integer
Dim BD() As Variant
 
  For i = 1 To UBound(BD)
     If BD(i, 2) = Me.Service And BD(i, 3) = Me.Fonction Then Me.Niveau = BD(i, 1)
  Next i
End Sub

07/11/2019, 10h38
unparia
Bonjour
Tu aurais pu avoir ce petit réflexe (un tout petit code) :
Code:

1 2 Dim BD() As Variant MsgBox UBound(BD)
qui t'aurait fait prendre conscience de ce que tu as déclaré une matrice, non dimensionnée (et donc ans ubound !), que ce fût de manière directe ou en lui affectant une plage de cellule

Résolu

Après relecture du code, le problème est résolu par l'ajout des lignes 32 et 45.

Merci Unparia. J'ai effectivement quelques réflexes à acquérir.

Code:

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
Option Explicit
 
Dim f As Worksheet
Private Sub UserForm_Initialize()
Dim BD() As Variant
Dim Tbl() As Variant
Dim d As New Dictionary
Dim i As Integer
 
  Set f = Sheets("test")
  Me.NoOrdre = f.Range("A" & Rows.Count).End(xlUp).Row
 
  Set f = Sheets("base")
  BD = f.Range("A2:C" & f.[B65000].End(xlUp).Row).Value
  Set d = CreateObject("Scripting.Dictionary")
  For i = 1 To UBound(BD)
    d(BD(i, 2)) = ""
  Next i
  Tbl = d.keys
  Tri Tbl, LBound(Tbl), UBound(Tbl)
  Me.Service.List = Tbl
 
End Sub
 
Private Sub Service_click()
Dim d As New Dictionary
Dim i As Integer
Dim BD() As Variant
Dim Tbl As Variant
 
  Me.Fonction.Clear
  BD = f.Range("A2:C" & f.[B65000].End(xlUp).Row).Value
  Set d = CreateObject("Scripting.Dictionary")
  For i = 1 To UBound(BD)
     If BD(i, 2) = Me.Service Then d(BD(i, 3)) = ""
  Next i
  Tbl = d.keys
  Tri Tbl, LBound(Tbl), UBound(Tbl)
  Me.Fonction.List = Tbl
End Sub
 
Private Sub Fonction_click()
Dim i As Integer
Dim BD() As Variant
BD = f.Range("A2:C" & f.[B65000].End(xlUp).Row).Value
  For i = 1 To UBound(BD)
     If BD(i, 2) = Me.Service And BD(i, 3) = Me.Fonction Then Me.Niveau = BD(i, 1)
  Next i
End Sub
 
Private Sub cb_ValiderSaisie_Click()
Dim n As Integer
Dim c As Control
Dim nom_control As String
 
  Me.ListBox1.AddItem Me.NoOrdre
  n = Me.ListBox1.ListCount - 1
  Me.ListBox1.List(n, 1) = Me.Nom
  Me.ListBox1.List(n, 2) = Me.Service
  Me.ListBox1.List(n, 3) = Me.Fonction
  Me.ListBox1.List(n, 4) = CDbl(Me.Niveau)
 
  For Each c In Me.Controls
  nom_control = c.Name
  If nom_control <> "NoOrdre" Then
  Select Case TypeName(c)
    Case "TextBox"
      c.Text = ""
  End Select
  End If
  Next c
 
  Me.NoOrdre = Me.NoOrdre + 1
 
  Me.Nom.SetFocus
End Sub
 
 
 
Private Sub cb_Modifier_Click()
 
  With Sheets("test")
    ListBox1.List = .Range("A2:D" & Cells(Application.Rows.Count, 1).End(xlUp).Row).Value
  End With
 
End Sub
 
Private Sub cb_SupprimerLigne_Click()
Dim Ligne As Integer
  Ligne = Me.ListBox1.ListIndex
  If Ligne <> -1 Then Me.ListBox1.RemoveItem Ligne
End Sub
 
Private Sub cb_Bordereau_click()
Dim a() As Variant
Dim DLigne As Integer
 
Set f = Sheets("test")
DLigne = IIf(f.Range("A1").Value = "", 1, f.Cells(Application.Rows.Count, "A").End(xlUp).Row + 1)
a = Me.ListBox1.List
f.Cells(DLigne, "A").Resize(UBound(a, 1) + 1, UBound(a, 2) + 1) = a
End Sub
 
 
Sub Tri(a, gauc, droi) ' Quick sort
Dim ref As Variant
Dim g As Variant
Dim d As Variant
Dim temp As Variant
 
   ref = a((gauc + droi) \ 2)
   g = gauc: d = droi
   Do
      Do While a(g) < ref: g = g + 1: Loop
      Do While ref < a(d): d = d - 1: Loop
      If g <= d Then
        temp = a(g): a(g) = a(d): a(d) = temp
        g = g + 1: d = d - 1
     End If
   Loop While g <= d
   If g < droi Then Call Tri(a, g, droi)
   If gauc < d Then Call Tri(a, gauc, d)
End Sub