Formulaire ListBox multi-sélection

Accueil

 

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

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

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

Sélections multiples dans une ListBox

FormSelectMultiples

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

FormSelectMultiples

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.

FormSelectMult

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.

Recherche Choix Multiple

Autre exemple

ListBox Cascade 3 niveaux

Filtre intersection d'ensembles

Filtre intersection d'ensembles

Choix multiples dans un combobox

FormChoixSuccessifsCombo

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

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

 

 


Exemples

Form Selection Multiple