Transférer des Noms entre 2 ListBox(s)

Bonjour,

Malgré mes recherches sur le forums et autres sites web, je n'arrive pas a trouver la solution a mon problème.

Même si je commence a comprendre certaines choses dans la programmation VBA, je n'en reste pas moins un Novice en la matière...

Je réalise un formulaire de présence journalière sur des activités. Pour réaliser la sélection des noms des participants je souhaite utiliser 2 listbox(s) me permettant de transférer via des boutons, les noms des personnes présentes de la ListBox "Disponible" vers la listBox "Sélectionné".

Les données contenues dans la Listbox "Disponible" sont rentrées avec la Fonction RowSource

Et celles qui seront sélectionnés dans la listbox "sélectionné" seront par la suite transférées dans une base de données

Mon problème :

Après avoir pris des exemples de codes, je n'arrive pas a réaliser les fonctions des 2 boutons qui doivent permettre de transférer mes données sélectionnées vers l'une ou l'autre listBox

Je vous joint mon fichier test

Il faudrait donc que quand je sélectionne un ou plusieurs noms, ceux ci soit transférés (et non copiés) dans l'autre listBox avec si possible la possibilité de garder l'ordre alphabétique des différentes ListBox

J’espère avoir été assez clair, merci d'avance pour votre aide

Bonjour et bienvenue sur le forum

Un esssai à tester. Te convient-il ?

Bye !

Bonjour et merci pour ton aide rapide

Oui c'est presque ça , je voudrais également que le ou les noms sélectionnés se retire de la première ListBox après le Transfer ?

Nouvelle version.

Bye !

Bonsoir,

Exemple en PJ

Dim f
Private Sub UserForm_Initialize()
  Set f = Sheets("BD")
  Me.Source.List = f.Range("A2:A" & f.[A65000].End(xlUp).Row).Value
  Me.Dest.List = f.Range("B2:B" & f.[b65000].End(xlUp).Row).Value
  ListeManque
End Sub

Private Sub b_prend_Click()
  If Me.Source.ListIndex <> -1 And Me.Source.ListCount > 0 Then
     Item = Me.Source '.List(i)
     Tbl = Me.Dest.List
     p = Application.Match(Item, Application.Index(Tbl, 0), 0)
     If IsError(p) Then Me.Dest.AddItem Item
     ListeManque
  End If
End Sub

Private Sub B_enlève_Click()
  If Me.Dest.ListCount > 0 And Me.Dest.ListIndex <> -1 Then Me.Dest.RemoveItem Me.Dest.ListIndex
  ListeManque
End Sub

Sub ListeManque()
  Set d = CreateObject("scripting.dictionary")
  For i = 0 To Dest.ListCount - 1
    d(Me.Dest.List(i)) = ""
  Next i
  Set d2 = CreateObject("scripting.dictionary")
  For i = 0 To Source.ListCount - 1
    tmp = Me.Source.List(i, 0)
    If Not d.exists(tmp) Then d2(tmp) = ""
  Next i
  Me.ListBox1.List = d2.keys
End Sub

Private Sub B_transfert_Click()
  f.[A2:B100].ClearContents
  f.[A2].Resize(Me.Source.ListCount, 1) = Me.Source.List
  f.[B2].Resize(Me.Dest.ListCount, 1) = Me.Dest.List
End Sub

Private Sub B_ajout_Click()
  Me.Source.AddItem
  pos = Me.Source.ListCount - 1
  Me.Source.List(pos, 0) = Me.TextBox1
End Sub

Private Sub B_sup_Click()
  If Me.Source.ListCount > 0 And Me.Source.ListIndex <> -1 Then
    Me.Source.RemoveItem Me.Source.ListIndex
  End If
  ListeManque
End Sub

Boisgontier

Merci gmb , c'est exactement ce qu'il me fallait ...

Merci également Boisgontierjacques.

Du coup voici la version final,en piece jointe, avec tout les boutons qui fonctionnent....