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
| Option Explicit
Dim interne As Boolean, sep As String, multiSel As Long, lbxListeOK As Boolean
Private Sub LbxListe_Change()
Dim ch As String, i As Long
If Not interne Then
ch = ""
For i = 0 To lbxListe.ListCount - 1
If lbxListe.Selected(i) = True And lbxListe.List(i) <> "" Then ch = ch & sep & lbxListe.List(i)
Next i
ch = Mid(ch, Len(sep) + 1)
ActiveCell = ch
End If
End Sub
Private Sub LbxListe_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
' un clic droit désélectionne ou sélectionne l'ensemble de la liste
Dim i As Long, state As Boolean
If multiSel = 0 Then Exit Sub
If Button = xlSecondaryButton Then ' si clic-droit
' nb sélections
state = True
For i = 0 To lbxListe.ListCount - 1
If lbxListe.Selected(i) Then state = False: Exit For
Next i
' si aucune sélection sélectionner tout
' sinon désélectionner tout
'If cpt = 0 Then state = True Else state = False
interne = True ' palliatif, EnableEvents ne marche pas
For i = 0 To lbxListe.ListCount - 1
lbxListe.Selected(i) = state
Next i
interne = False
End If
LbxListe_Change
End Sub
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
' Création de la listBox
Dim Obj As OLEObject
If Target.Address = "$A$1" Then
Cancel = True
For Each Obj In ActiveSheet.OLEObjects
If TypeName(Obj.Object) = "ListBox" Then
If Obj.Name = "lbxListe" Then Exit Sub
End If
Next Obj
' créer
ActiveSheet.OLEObjects.Add(ClassType:="Forms.ListBox.1", Link:=False, _
DisplayAsIcon:=False, Left:=200, Top:=200, Width:=90, Height:=108).Name = "lbxListe"
MsgBox "lbxListe créée"
End If
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'******** Constante à adapter **********************************************************
Const FeuilleListe As String = "Listes" ' nom de la feuille des listes à utiliser
'***************************************************************************************
Dim ch As String, ch2 As String, i As Long
Dim topIndex As Boolean
Dim param, ref
Dim lig As Long, dercol As Long, c As Range
If Target.Count > 1 Then Exit Sub
' contrôles validité
With Sheets(FeuilleListe)
param = .[A1].CurrentRegion ' paramètres d'utilisations des listes
'1 , 2 , 3 , 4 , 5 , 6 , 7
'Référence, Liste utilisée, Type, Width, Height, Multi, Sep
For lig = 3 To UBound(param, 1)
ref = Split(Mid(param(lig, 1), 2), "!")
If ref(0) = Target.Parent.Name Then ' test nom feuille d'appel
If Not Intersect(Target, Range(ref(1))) Is Nothing Then 'test plage d'appel
dercol = .Cells(2, Columns.Count).End(xlToLeft).Column
' test nom de liste
Set c = .Rows(1).Find("Listes", LookIn:=xlValues, Lookat:=xlWhole)
Set c = c.Offset(1).Resize(, dercol - c.Column + 1).Find(param(lig, 2), LookIn:=xlValues, Lookat:=xlWhole)
If c Is Nothing Then
MsgBox "Liste '" & param(lig, 2) & "' non trouvée.": lig = UBound(param, 1)
Else
'plage liste
Set c = c.Offset(1).Resize(.Cells(Rows.Count, c.Column).End(xlUp).Row - 2)
Exit For
End If
End If
End If
Next lig
End With
' ne plus afficher la textbox
lbxListe.Visible = False
If lig <= UBound(param, 1) Then
' initialiser listbox
Select Case param(lig, 3)
Case "ListBox"
With lbxListe
.ListFillRange = "'" & FeuilleListe & "'!" & c.Address
.Top = Target.Offset(1, 0).Top
.Left = Target.Offset(0, 1).Left
If param(lig, 4) <> "" Then .Width = param(lig, 4)
If param(lig, 5) <> "" Then .Height = param(lig, 5)
multiSel = param(lig, 6)
interne = True
.MultiSelect = multiSel
interne = False
sep = param(lig, 7)
End With
interne = True ' palliatif, EnableEvents ne marche pas
ch = Target
ch2 = sep & ch & sep
topIndex = False
' sélectionner selon contenu cellule
For i = 0 To lbxListe.ListCount - 1
If InStr(ch2, sep & lbxListe.List(i) & sep) > 0 Then
' l'item a été trouvé dans la cellule
lbxListe.Selected(i) = True
If Not topIndex Then
lbxListe.topIndex = i ' le 1er sélectionné doit être visible dans la textbox
topIndex = True
End If
End If
Next i
interne = False
' afficher textbox
lbxListe.Visible = True
End Select
End If
End Sub
Sub reinit()
Application.EnableEvents = True
End Sub |
Liste déroulante avec choix multiple
Répondre avec citation
Envoyé par letoutcasse2000
Partager