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
Filtre de plusieurs régions
Choix successifs dans un comboBox
Transfert listbox multi-sélection & multi-colonnes dans une autre listbox

La propriété MultiSelect = fmMultiSelectMulti permet les choix multiples. MultiSelect = fmMultiSelectSingle
n'autorise que la sélection simple

SelectionMultiple

Private Sub UserForm_Initialize()
  Me.Source.AddItem "aaa"
  Me.Source.AddItem "bbb"
  Me.Source.AddItem "ccc"
  Me.Source.AddItem "ddd"
  Me.Source.AddItem "eee"
  Me.Source.AddItem "fff"
  Me.Source.AddItem "ggg"
  Me.Source.AddItem "hhh"
  Me.Source.MultiSelect = fmMultiSelectMulti
End Sub

Private Sub CommandButton1_Click()
   For i = 0 To Me.Source.ListCount - 1
     If Me.Source.Selected(i) = True Then temp = temp & Me.Source.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

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

Sélection multiple ListBox en cascade & extraction

Recherche Choix Multiple

Choix en cascade ListBox 3 niveaux

ListBox Cascade 3 niveaux

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


Exemples

Form Selection Multiple