Récupération d'une sélection multiple
ListBox dans le tableur
Choix multiples dans ListBox
Transfert multi-sélection d'une ListBox dans une
autre ListBox
Choix multiples dans une ListBox
Choix multiple en cascade dans ListBox & Extraction
ListBox Multi-sélection 2 niveaux
ListBox multi-sélection 3 niveaux
Filtre de plusieurs régions
Choix successifs dans un comboBox
Transfert listbox multi-sélection & multi-colonnes
dans une autre listbox
Affiche/Cache les feuilles du classeur sélectionnées
Groupe options multiples
Formulaire saisie avec ListBox Multi-sélection
La propriété MultiSelect = fmMultiSelectMulti
permet les choix multiples. MultiSelect = fmMultiSelectSingle
n'autorise que la sélection simple
Selection
Multiple
Selection Multiple
Limité
Selection Multiple
Minimum
Private Sub UserForm_Initialize()
Me.Listbox1.List = Range("a1:a" & [a65000].End(xlUp).Row).Value
Me.Listbox1.MultiSelect = fmMultiSelectMulti
End Sub
Private Sub CommandButton1_Click()
For i = 0 To Me.Listbox1.ListCount - 1
If Me.Listbox1.Selected(i) = True Then temp =
temp & Me.Listbox1.List(i) & " "
Next i
MsgBox temp
End Sub
Récupération d'une sélection multiple d'une ListBox dans le tableur
Recup
Multi Sélection
Suppression Multi
Sélection
Private Sub UserForm_Initialize()
Set f = Sheets("bd")
Set plg = f.Range("a2:b" & f.[a65000].End(xlUp).Row)
Me.ListBox1.List = plg.Value
Me.ListBox1.MultiSelect = fmMultiSelectMulti
End Sub
Private Sub CommandButton1_Click()
Sheets("recup").[A2:B1000].ClearContents
ligne = 2
For i = 0 To Me.ListBox1.ListCount - 1
If Me.ListBox1.Selected(i) = True Then
Sheets("recup").Cells(ligne,
1) = Me.ListBox1.List(i)
Sheets("recup").Cells(ligne,
2) = Me.ListBox1.List(i, 1)
ligne = ligne + 1
End If
Next i
End Sub
Filtre sur une ListBox longue
Filtre sur Sélection Listbox longue
Option Compare Text
Dim d
Private Sub UserForm_Initialize()
Set d = CreateObject("scripting.dictionary")
For Each c In [villes]
d(c.Value) = False
Next c
Me.ListBox1.MultiSelect = fmMultiSelectMulti
Me.ListBox1.List = [villes].Value
End Sub
Private Sub listbox1_change()
n = 0
For i = 0 To Me.ListBox1.ListCount - 1
clé = Me.ListBox1.List(i)
v = Me.ListBox1.Selected(i)
d(clé) = v
Next i
For Each c In d.keys
If d(c) Then n = n + 1
Next c
Me.TextBox1 = n
End Sub
Private Sub TextBox3_Change()
Me.ListBox1.Clear
If Me.TextBox3 <> "" Then
n = 0
For Each c In d.keys
If Left(c, 1) = Me.TextBox3 Then
Me.ListBox1.AddItem c
Me.ListBox1.Selected(n)
= d(c)
n = n + 1
End If
Next c
Else
n = 0
For Each c In d.keys
Me.ListBox1.AddItem c
Me.ListBox1.Selected(n) = d(c)
n = n + 1
Next c
End If
End Sub
Private Sub b_tout_Click()
Me.TextBox3 = ""
End Sub
Sélections multiples et sauvegarde
On sauvegarde les sélections.
Option Compare Text
Dim f, Tous(), d
Private Sub UserForm_Initialize()
Set f = Sheets("villes")
Me.Source2.MultiSelect = fmMultiSelectMulti
If f.[f2] = "" Then
Me.Source2.List = [villes].Value
Else
Set Rng = f.Range("e2:e"
& f.[e65000].End(xlUp).Row)
Rng.Sort key1:=f.[e2], Order1:=xlAscending,
Header:=xlNo
[Source2].List = f.Range("e2:e"
& f.[e65000].End(xlUp).Row).Value
Set Rng = f.Range("f2:f"
& f.[f65000].End(xlUp).Row)
Rng.Sort key1:=f.[f2], Order1:=xlAscending,
Header:=xlNo
[Dest].List = f.Range("f2:f"
& f.[f65000].End(xlUp).Row).Value
End If
Set d = CreateObject("scripting.dictionary")
For i = 0 To Me.Source2.ListCount - 1
d(Me.Source2.List(i)) = False
Next i
Me.TextBox1 = Me.Dest.ListCount
End Sub
Private Sub b_prend2_Click()
b_tout_Click
If Me.Source2.ListIndex <> -1 And Me.Source2.ListCount
> 0 Then
For i = 0 To Me.Source2.ListCount - 1
If Me.Source2.Selected(i) = True Then
Me.Dest.AddItem Me.Source2.List(i)
clé = Me.Source2.List(i)
d.Remove clé
End If
Next i
For i = Me.Source2.ListCount - 1 To 0 Step -1
If Me.Source2.Selected(i) = True Then
Me.Source2.RemoveItem
i
End If
Next i
End If
Me.TextBox1 = Me.Dest.ListCount
End Sub
Private Sub B_enlève_Click()
If Me.Dest.ListCount > 0 And Me.Dest.ListIndex <>
-1 Then
Me.Source2.AddItem Me.Dest
Me.Dest.RemoveItem Me.Dest.ListIndex
clé = Dest
d(clé) = False
End If
Me.TextBox1 = Me.Dest.ListCount
End Sub
Private Sub Dest_Change()
For i = 0 To Me.Source2.ListCount - 1
clé = Me.Source2.List(i)
v = Me.Source2.Selected(i)
d(clé) = v
Next i
End Sub
Private Sub Source2_change()
For i = 0 To Me.Source2.ListCount - 1
clé = Me.Source2.List(i)
v = Me.Source2.Selected(i)
d(clé) = v
Next i
End Sub
Sélections multiples dans une ListBox
Dim f
Private Sub UserForm_Initialize()
Set f = Sheets("stype")
Set MonDico = CreateObject("Scripting.Dictionary")
For Each c In Range(f.[A2], f.[A65000].End(xlUp))
If c.Value <> "" Then MonDico.Item(c.Value)
= c.Value
Next c
Me.ListBoxType.List = MonDico.items
End Sub
Private Sub ListBoxType_Change()
Me.ListBoxSType.Clear
For i = 0 To Me.ListBoxType.ListCount - 1
If Me.ListBoxType.Selected(i) = True Then
For Each c In Range(f.[A2], f.[A65000].End(xlUp))
If c = Me.ListBoxType.List(i)
Then Me.ListBoxSType.AddItem c.Offset(, 1)
Next c
End If
Next i
End Sub
Form
Select Multiples Activités Risques
Form Select Multiples
Activités Risques 2
Choix multiples dans une ListBox
DVChoixRégions
DVChoixRégionOption
DV
Choix Multiples Form
Private Sub UserForm_Initialize()
ListBox1.MultiSelect = fmMultiSelectMulti
ListBox1.List = Sheets("BD").Range("A2:A28").Value
a = Split(ActiveCell, " ")
If UBound(a) >= 0 Then
For i = 0 To Me.ListBox1.ListCount - 1
If Not IsError(Application.Match(Me.ListBox1.List(i),
a, 0)) Then Me.ListBox1.Selected(i) = True
Next i
End If
End Sub
Private Sub Ok_Click()
For i = 0 To Me.ListBox1.ListCount - 1
If Me.ListBox1.Selected(i) = True Then temp
= temp & Me.ListBox1.List(i) & " "
Next i
ActiveCell = Trim(temp)
Unload Me
End Sub
Avec des cases à cocher
DV Choix Remarques ListBox Options
Filtre régions dans une ListBox
On filtre pour une ou plusieurs régions choisies dans un ListBox.
FiltreRégions
FiltreRégionsFiltreElaboré
Private Sub Filtrer_Click()
Set d = CreateObject("scripting.dictionary")
Set f = Sheets("national")
For i = 0 To Me.ListBox1.ListCount - 1
If Me.ListBox1.Selected(i) = True Then d(Me.ListBox1.List(i))
= ""
Next i
If d.Count > 0 Then
For Each c In f.Range("F9 :F" &
f.[F65000].End(xlUp).Row)
c.EntireRow.Hidden = IsError(Application.Match(c,
d.keys, 0))
Next c
End If
Unload Me
End Sub
Private Sub UserForm_Initialize()
ListBox1.MultiSelect = fmMultiSelectMulti
ListBox1.List = Sheets("Régions").Range("F2:F28").Value
End Sub
Pour limiter le choix à 4 régions
Private Sub ListBox1_Change()
temp = Me.ListBox1.ListIndex
n = 0
For i = 0 To Me.ListBox1.ListCount - 1
If Me.ListBox1.Selected(i) = True Then n = n +
1
Next i
If n > 4 Then Me.ListBox1.Selected(temp) = False
End Sub
Choix multiples dans une ListeBox
Récupération dans un tableau
Dim f, a(1 To 20, 1 To 2)
Sub UserForm_Initialize()
Set f = Sheets("bd")
Me.ListBox1.List = Range(f.[A2], f.[b65000].End(xlUp)).Value
Me.ListBox1.MultiSelect = fmMultiSelectMulti
End Sub
Private Sub ListBox1_Change()
ligne = 0
For k = 0 To Me.ListBox1.ListCount - 1
If Me.ListBox1.Selected(k) = True Then
ligne = ligne + 1
a(ligne, 1) = Me.ListBox1.List(k,
0)
a(ligne, 2) = Me.ListBox1.List(k,
1)
End If
Next k
End Sub
Private Sub cmdValider_Click()
f.Cells(2, "e").Resize(20, 2).ClearContents
f.Cells(2, "e").Resize(UBound(a), 2) = a
Unload Me
End Sub
On récupère le résultat des choix d'une ListBox dans une cellule.
Dim f, mondico
Sub UserForm_Initialize()
Set f = Sheets("bd")
Set mondico = CreateObject("Scripting.Dictionary")
Me.choix.List = Range(f.[A2], f.[b65000].End(xlUp)).Value
Me.choix.MultiSelect = fmMultiSelectMulti
End Sub
Private Sub Choix_Change()
mondico.RemoveAll
Me.RésultatListBox1.Clear
For k = 0 To Me.choix.ListCount - 1
If Me.choix.Selected(k) = True Then
temp = Me.choix.List(k, 0) &
" " & Me.choix.List(k, 1)
mondico(temp) = temp
End If
Next k
Me.RésultatListBox1.List = mondico.items
End Sub
Private Sub cmdValider_Click()
[E1] = Join(mondico.items, Chr(10))
Unload Me
End Sub
Choix de plusieurs fichiers dans une ListBox
Private Sub UserForm_Initialize()
ChDir ActiveWorkbook.Path
Répertoire = CurDir() ' nom du répertoire
courant
masque = Répertoire + "\*.xls"
nf = Dir(masque) ' 1er classeur du répertoire
Do While nf <> ""
Me.Choix.AddItem nf
nf = Dir() ' classeur suivant
Loop
End Sub
Private Sub B_multiple_Click()
Me.Choix.MultiSelect = fmMultiSelectMulti
End Sub
Private Sub B_simple_Click()
Me.Choix.MultiSelect = fmMultiSelectSingle
End Sub
Private Sub B_imprime_Click()
For i = 0 To Me.Choix.ListCount - 1
If Me.Choix.Selected(i) = True Then
nf = Me.Choix.List(i)
Application.DisplayAlerts = False
Workbooks.Open FileName:=nf
ActiveSheet.PrintPreview
ActiveWorkbook.Close
End If
Next
End Sub
Choix en cascade ListBox multi-sélection 2 niveaux
ListBox
Cascade 2 niveaux
ListBox
Cascade 2 niveaux mémorisation
Choix en cascade ListBox multi-sélection 3 niveaux
La version mémorisation permet de rappeler une interrogation précédente et de la modifier.
ListBox
Cascade 3 niveaux
ListBox Cascade
3 niveaux mémorisation
ListBox
Cascade 3 niveaux mémorisation 2
Dim f, dchoisis1
Private Sub UserForm_Initialize()
Set f = Sheets("BD")
Set d = CreateObject("Scripting.Dictionary")
For Each c In Range(f.[A2], f.[A65000].End(xlUp))
d(c.Value) = ""
Next c
Me.ListBox1.List = d.keys
Me.ListBox1.MultiSelect = fmMultiSelectMulti
Me.ListBox2.MultiSelect = fmMultiSelectMulti
Me.ListBox3.MultiSelect = fmMultiSelectMulti
End Sub
Private Sub ListBox1_Change()
Me.ListBox3.Clear
Set dchoisis1 = CreateObject("Scripting.Dictionary")
For i = 0 To Me.ListBox1.ListCount - 1
If Me.ListBox1.Selected(i) Then dchoisis1(Me.ListBox1.List(i,
0)) = ""
Next i
Set d = CreateObject("Scripting.Dictionary")
For Each c In Range(f.[A2], f.[A65000].End(xlUp))
If dchoisis1.exists(c.Value) Then d(c.Offset(,
1).Value) = ""
Next c
If d.Count > 0 Then Me.ListBox2.List = d.keys Else Me.ListBox2.Clear
End Sub
Private Sub ListBox2_Change()
Set dchoisis2 = CreateObject("Scripting.Dictionary")
For i = 0 To Me.ListBox2.ListCount - 1
If Me.ListBox2.Selected(i) Then dchoisis2(Me.ListBox2.List(i,
0)) = ""
Next i
Set d = CreateObject("Scripting.Dictionary")
For Each c In Range(f.[A2], f.[A65000].End(xlUp))
If dchoisis1.exists(c.Value) And dchoisis2.exists(c.Offset(,
1).Value) Then d(c.Offset(, 2).Value) = ""
Next c
If d.Count > 0 Then Me.ListBox3.List = d.keys Else Me.ListBox3.Clear
End Sub
Recherche multiple continents/pays/villes
Recherche multiple continents Pays villes
Sélection multiple ListBox en cascade & extraction
Extrait d'une BD les lignes qui correspondent à la sélection multiple 3 niveaux.
Autre exemple
Filtre intersection d'ensembles
Filtre
intersection d'ensembles
Choix multiples dans un combobox
Dim choix
Dim témoin As Boolean
Private Sub ComboBox1_Click()
p = InStr(choix, Me.ComboBox1)
If p = 0 Then '-- ajout
If choix = "" Then choix = Me.ComboBox1
Else choix = choix & ":" & Me.ComboBox1
Me.ComboBox1 = choix
Else ' suppression s'il est déjà choisi
If Not témoin Then
a = Split(choix, ":")
témoin = (UBound(a) - LBound(a)
= 1)
choix = Left(choix, p - 1) & Mid(choix,
p + Len(Me.ComboBox1) + 1)
If Right(choix, 1) = ":"
Then choix = Left(choix, Len(choix) - 1)
Me.ComboBox1 = choix
Else
témoin = False
End If
End If
End Sub
Transfert listbox multi-colonnes & multi-sélection dans une autre listebox
Transfert multi colonnes et multisélection
Dim f
Private Sub UserForm_Initialize()
Set f = Sheets("feuil1")
Me.Source.List = f.Range("A2:B" & f.[A65000].End(xlUp).Row).Value
Me.Source.MultiSelect = fmMultiSelectMulti
End Sub
Private Sub b_prend_Click()
If Me.Source.ListIndex <> -1 And Me.Source.ListCount
> 0 Then
For i = 0 To Me.Source.ListCount - 1
If Me.Source.Selected(i) = True
Then
Me.Dest.AddItem
Me.Source.List(i)
pos = Me.Dest.ListCount
- 1
Me.Dest.List(pos,
1) = Me.Source.List(i, 1)
End If
Next i
End Sub
Transfert Multi-sélection et Multi-colonnes dans ListBox
Transfert multi colonnes et multisélection
Dim f
Private Sub UserForm_Initialize()
Set f = Sheets("feuil1")
Me.Source.List = f.Range("A2:B" & f.[A65000].End(xlUp).Row).Value
Me.Source.MultiSelect = fmMultiSelectMulti
End Sub
Private Sub b_prend_Click()
If Me.Source.ListIndex <> -1 And Me.Source.ListCount
> 0 Then
For i = 0 To Me.Source.ListCount - 1
If Me.Source.Selected(i) = True
Then
Me.Dest.AddItem
Me.Source.List(i)
pos = Me.Dest.ListCount
- 1
Me.Dest.List(pos,
1) = Me.Source.List(i, 1)
End If
Next i
For i = Me.Source.ListCount - 1 To 0 Step
-1
If Me.Source.Selected(i)
= True Then Me.Source.RemoveItem i
Next i
End If
End Sub
Private Sub B_enlève_Click()
If Me.Dest.ListCount > 0 And Me.Dest.ListIndex <>
-1 Then
Me.Source.AddItem Me.Dest
pos = Me.Source.ListCount - 1
Me.Source.List(pos, 1) = Me.Dest.Column(1)
Me.Dest.RemoveItem Me.Dest.ListIndex
End If
End Sub
Autre exemple
Sur cet exemple:
-On peut ajouter des items
-Déplacer un item
Transfert
multi colonnes et multisélection
Transfert
multi colonnes et multisélection 2
Transfert multi colonnes
et multisélection 6 colonnes
Dim f
Private Sub UserForm_Initialize()
Set f = Sheets("feuil1")
Me.Source.List = f.Range("A2:B" & f.[A65000].End(xlUp).Row).Value
Me.Source.MultiSelect = fmMultiSelectMulti
End Sub
Private Sub b_prend_Click()
If Me.Source.ListIndex <> -1 And Me.Source.ListCount
> 0 Then
For i = 0 To Me.Source.ListCount - 1
If Me.Source.Selected(i) = True Then
Me.Dest.AddItem
Me.Source.List(i)
pos = Me.Dest.ListCount
- 1
Me.Dest.List(pos,
1) = Me.Source.List(i, 1)
End If
Next i
For i = Me.Source.ListCount - 1 To 0 Step -1
If Me.Source.Selected(i) = True
Then Me.Source.RemoveItem i
Next i
End If
End Sub
Private Sub B_enlève_Click()
If Me.Dest.ListCount > 0 And Me.Dest.ListIndex <>
-1 Then
Me.Source.AddItem Me.Dest
pos = Me.Source.ListCount - 1
Me.Source.List(pos, 1) = Me.Dest.Column(1)
Me.Dest.RemoveItem Me.Dest.ListIndex
End If
End Sub
Private Sub B_ajout_Click()
Me.Dest.AddItem
pos = Me.Dest.ListCount - 1
Me.Dest.List(pos, 0) = Me.TextBox1
Me.Dest.List(pos, 1) = Me.TextBox2
End Sub
Private Sub B_monte_Click()
If Me.Dest.ListIndex <> -1 And Me.Dest.ListIndex >
0 Then
element = Me.Dest.List(Dest.ListIndex, 0)
element2 = Me.Dest.List(Dest.ListIndex,
1)
p = Me.Dest.ListIndex
Me.Dest.AddItem element, p - 1
Me.Dest.List(p - 1, 1) = element2
Me.Dest.RemoveItem Me.Dest.ListIndex
Me.Dest.ListIndex = p - 1
End If
End Sub
Private Sub B_descend_Click()
If Me.Dest.ListIndex <> -1 And Me.Dest.ListIndex
< Me.Dest.ListCount - 1 Then
element = Me.Dest.List(Dest.ListIndex,
0)
element2 = Me.Dest.List(Dest.ListIndex,
1)
p = Me.Dest.ListIndex
Me.Dest.AddItem element, p + 2
Me.Dest.List(p + 2, 1) = element2
Me.Dest.RemoveItem Me.Dest.ListIndex
Me.Dest.ListIndex = p + 1
End If
End Sub
Private Sub B_transfert_Click()
Sheets("feuil2").[A2].Resize(Me.Dest.ListCount,
2) = Me.Dest.List
End Sub
Autre exemple
Lors d'un ajout de titre, l'opérateur choisit successivement
dans un ComboBox les différents acteurs d'une liste.
Il peut ajouter dynamiquement un nouvel acteur en frappant ,XXXXXX. Celui
ci est ajouté à la liste des acteurs.
AjoutDynamiqueActeur
Form Films Saisie
Dim f, choix, témoin As Boolean
Private Sub UserForm_Initialize()
Set f = Sheets("bd")
Me.ComboBox1.List = Range("acteurs").Value
Me.ListBox2.List = Range("nature").Value
Me.Listbox3.List = Range("nationalité").Value
End Sub
Private Sub ComboBox1_Click()
p = InStr(choix, Me.ComboBox1)
If p = 0 Then '-- ajout
If choix = "" Then choix = Me.ComboBox1
Else choix = choix & "," & Me.ComboBox1
Me.ComboBox1 = choix
Else ' suppression s'il est déjà
choisi
If Not témoin Then
a = Split(choix,
":")
témoin =
(UBound(a) - LBound(a) = 1)
choix = Left(choix,
p - 1) & Mid(choix, p + Len(Me.ComboBox1) + 1)
If Right(choix,
1) = "," Then choix = Left(choix, Len(choix) - 1)
Me.ComboBox1 = choix
Else
témoin = False
End If
End If
End Sub
Private Sub B_valid_Click()
If Me.TextBox1 = "" Then
MsgBox "saisir un titre!"
Me.TextBox1.SetFocus
Exit Sub
End If
ligneEnreg = f.[A65000].End(xlUp).Row + 1
For i = 0 To Me.ListBox2.ListCount - 1
If Me.ListBox2.Selected(i) = True Then temp1
= temp1 & Me.ListBox2.List(i) & ","
Next i
If Len(temp1) > 1 Then temp1 = Left(temp1, Len(temp1) -
1)
For i = 0 To Me.Listbox3.ListCount - 1
If Me.Listbox3.Selected(i) = True Then temp2
= temp2 & Me.Listbox3.List(i) & ","
Next i
If Len(temp2) > 1 Then temp2 = Left(temp2, Len(temp2) -
1)
'-- transfert bd
Cells(ligneEnreg, "a") = Me.TextBox1
Cells(ligneEnreg, "b") = Me.ComboBox1
a = Split(Me.ComboBox1, ",")
For Each c In a
p = Application.Match(c, [acteurs], 0)
If IsError(p) Then
[acteurs].End(xlDown).Offset(1) =
c
Sheets("données").[acteurs].Sort
key1:=Sheets("données").Range("acteurs")
End If
Next c
Cells(ligneEnreg, "c") = temp1
Cells(ligneEnreg, "d") = temp2
Cells(ligneEnreg, "e") = Me.TextBox2
f.[A2].Sort key1:=Range("a2"), Order1:=xlAscending,
Header:=xlYes
Unload Me
End Sub
Affiche/Cache feuille
Affiche/Cache
feuille ListBox
Affiche/Cache
feuille ComboBox
Masque/Affiche les feuilles choisies.
Dim témoin
Private Sub UserForm_Initialize()
Me.ListBox1.Clear
For i = 2 To ActiveWorkbook.Sheets.Count
Me.ListBox1.AddItem Sheets(i).Name
Me.ListBox1.Selected(i - 2) = Sheets(i).Visible
Next i
témoin = True
End Sub
Private Sub ListBox1_change()
If témoin Then
For i = 0 To Me.ListBox1.ListCount - 1
f = ListBox1.List(i)
Sheets(f).Visible = Me.ListBox1.Selected(i)
Next i
End If
End Sub
Autre version
Sommaire Onglets Affiche/Cache
Dim témoin
Private Sub Worksheet_Activate()
témoin = True
ListBox1.Clear
For s = 2 To Sheets.Count
ListBox1.AddItem Sheets(s).Name
ListBox1.Selected(s - 2) = Sheets(s).Visible
Next s
témoin = False
End Sub
Private Sub ListBox1_change()
If Not témoin Then
For i = 0 To Me.ListBox1.ListCount - 1
temp = ListBox1.List(i)
Sheets(temp).Visible = Me.ListBox1.Selected(i)
Next i
End If
End Sub
Groupe options multiples dynamiques avec ListBox
Permet de choisir une ou plusieurs options.
Groupe
Options Multiples
Groupe Options
Multiples 2
Option Compare Text
Dim TblBD()
Private Sub UserForm_Initialize()
TblBD = [client].Value ' pour rapidité
TriMultiCol TblBD, 1, UBound(TblBD), 3
Set d = CreateObject("scripting.dictionary")
For i = 1 To [client].Rows.Count
tmp = TblBD(i, 3): d(tmp) = ""
Next i
Me.OptionsGroupe.MultiSelect = fmMultiSelectMulti
Me.OptionsGroupe.ListStyle = 1 'frmliststyleoption
Tbl = d.keys
Tri Tbl, LBound(Tbl), UBound(Tbl)
Me.OptionsGroupe.List = Tbl
Me.ListBox1.ColumnCount = [client].Columns.Count + 1
Me.ListBox1.ColumnWidths = "60;50;30;50;100;70;70;50"
Me.ListBox1.List = TblBD
End Sub
Private Sub OptionsGroupe_change()
Set dchoisis1 = CreateObject("Scripting.Dictionary")
For i = 0 To Me.OptionsGroupe.ListCount - 1
If Me.OptionsGroupe.Selected(i) Then dchoisis1(Me.OptionsGroupe.List(i,
0)) = ""
Next i
Dim Tbl2(): n = 0: Ncol = UBound(TblBD, 2)
For i = 1 To UBound(TblBD)
tmp = TblBD(i, 3)
If dchoisis1.exists(tmp) Then
n = n + 1: ReDim Preserve Tbl2(1 To
Ncol, 1 To n)
For k = 1 To Ncol: Tbl2(k, n) = TblBD(i,
k): Next k
End If
Next i
If n > 0 Then Me.ListBox1.Column = Tbl2 Else Me.ListBox1.Clear
End Sub
Sur cette version, il y a 2 à 3 colonnes de recherche paramétrées.
Groupe
Options Multiples 4 critères
Groupe
Options Multiples 4 critères bis
Groupe
Options Multiples 5 critères
Formulaire de saisie avec ListBox multi-sélection
Form Consultation Modification Ajout Trié
Enregistrement
'-- loisirs
temp = ""
For i = 0 To Me.Loisirs.ListCount - 1
If Me.Loisirs.Selected(i) = True Then temp = temp
& Me.Loisirs.List(i) & ";"
Next i
f.Cells(ligneEnreg, 8) = temp
Restitution
'--- loisirs
temp = f.Cells(ligneEnreg, 8)
a = Split(temp, ";")
For j = 0 To Me.Loisirs.ListCount - 1: Me.Loisirs.Selected(j)
= False: Next j
If UBound(a) >= 0 Then
For j = 0 To Me.Loisirs.ListCount - 1
If Not IsError(Application.Match(Me.Loisirs.List(j),
a, 0)) Then
Me.Loisirs.Selected(j)
= True
Else
Me.Loisirs.Selected(j)
= False
End If
Next j
End If
Exemples |
| Form Selection Multiple |