Formulaire multi-sélection

Accueil

 

Récupération d'une sélection multiple dans le tableur
Choix multiples
Transfert multi-sélection dans une autre liste
Choix multiples
Choix multiple en cascade & Extraction
Filtre de plusieurs régions
Choix successifs dans un comboBox

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 liste

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 avec formulaire

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

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 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

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 en cascade & extraction

Recherche Choix Multiple

Transfert multi-sélection dans une autre liste

Private Sub UserForm_Initialize()
  Me.ListBox1.List = [MaBD].Value
  Me.ListBox1.MultiSelect = fmMultiSelectMulti
End Sub

Private Sub CommandButton1_Click()
  Me.ListBox2.Clear
  k = 0
  For i = 0 To Me.ListBox1.ListCount - 1
    If Me.ListBox1.Selected(i) = True Then
      Me.ListBox2.AddItem
      Me.ListBox2.List(k, 0) = Me.ListBox1.List(i, 0)
      Me.ListBox2.List(k, 1) = Me.ListBox1.List(i, 1)
      k = k + 1
    End If
  Next i
End Sub

 

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

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