Transfert liste

Transfert ListBox

ListBox Transfert Simple
Liste transfert Fichiers
ListBox Transfert Trié
Glisser/Déplacer ListBox

ListBox transfert simple

Les éléments choisis dans la liste de gauche sont supprimés au fur et à mesure des choix.

ListBox Transfert Simple
Transfert ListBox multi-colonnes

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"
End Sub

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

Private Sub b_prend_Click()
   If Me.Source.ListIndex <> -1 And Me.Source.ListCount > 0 Then
     Me.Dest.AddItem Me.Source
     Me.Source.RemoveItem Me.Source.ListIndex
  End If
End Sub

Avec multi-sélection

Private Sub b_prend_Click()
  For i = 0 To Me.Source.ListCount - 1
    If Me.Source.Selected(i) = True Then Me.Dest.AddItem Me.Source.List(i)
  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 Sub

Autre exemple

ListBox Transfert Simple
Suivi de séries (films)

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

Sélections multiples,transfert et sauvegarde

On sauvegarde les sélections.

Multi Sélection sauvegarde
Transfert double clic sauvegarde

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

Transfert ListBox vec Multi-sélection et Multi-colonnes

Transfert multi colonnes et multisélection

Private Sub UserForm_Initialize()
Me.Source.List = [A2:B8].Value
Me.Source.MultiSelect = fmMultiSelectMulti
End Sub

Private Sub b_prend_Click()
  For i = 0 To Me.Source.ListCount - 1
    If Me.Source.Selected(i) = True Then
      p = Me.Dest.ListCount
      Me.Dest.AddItem
      Me.Dest.List(p, 0) = Me.Source.List(i, 0)
      Me.Dest.List(p, 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 Sub

Private Sub B_enlève_Click()
  p = Me.Source.ListCount
  Me.Source.AddItem
  Me.Source.List(p, 0) = Me.Dest
  Me.Source.List(p, 1) = Me.Dest.Column(1)
  Me.Dest.RemoveItem Me.Dest.ListIndex
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

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

ListBox transfert fichiers

On transfère de la liste de gauche(Source) vers la liste de droite (Dest)

ListeTransfert.xls

Private Sub UserForm_Initialize()
ChDir ActiveWorkbook.Path
Répertoire = CurDir()             ' nom du répertoire courant
masque = Répertoire + "\*.xls"    ' Masque: tous fichiers xls
nf = Dir(masque)                  ' 1er classeur du répertoire
Do While nf <> ""
    Me.Source.AddItem nf
    nf = Dir()                      ' classeur suivant
Loop
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
End If
End Sub

Private Sub b_prend_Click()
If Me.Source.ListIndex <> -1 Then
Me.Dest.AddItem Me.Source
' Me.Source.RemoveItem Me.Source.ListIndex
End If
End Sub

Private Sub b_tout_Click()
   Me.Dest.Clear
   For i = 0 To Me.Source.ListCount - 1
     Me.Dest.AddItem Me.Source.List(i)
   Next i
End Sub

Private Sub b_efface_dest_Click()
Me.Dest.Clear
End Sub

Private Sub b_imprime_Click()
   For i = 0 To Me.Dest.ListCount - 1
      nf = Me.Dest.List(i)
      Application.DisplayAlerts = False
      Workbooks.Open FileName:=nf
      ActiveSheet.PrintPreview
      ActiveWorkbook.Close
   Next i
End Sub

Pour éviter les doublons dans Dest

Private Sub b_prend_Click()
If Me.Source.ListIndex <> -1 Then
   témoin = False
   For i = 0 To Me.Dest.ListCount - 1
      If Me.Source = Me.Dest.List(i) Then témoin = True
   Next i
   If Not témoin Then Me.Dest.AddItem Me.Source
End If
End Sub

Supprimer les options dans la liste Source

Private Sub b_prend_Click()
If Me.Source.ListIndex <> -1 Then
Me.Dest.AddItem Me.Source
Me.Source.RemoveItem Me.Source.ListIndex
End If
End Sub

Transfert listBox triée

ListeTransfertTrié.xls

Dim MonDico As Object
Private Sub b_prend_Click()
If Me.Source.ListIndex <> -1 Then
    temp = Me.Source
    If Not MonDico.Exists(x) Then MonDico.Add temp, temp
    AfficheTrié
End If
End Sub

Private Sub b_enlève_Click()
If Me.Resultat.ListIndex <> -1 Then
MonDico.Remove (Me.Resultat)
AfficheTrié
End If
End Sub

Sub AfficheTrié()
    temp = MonDico.items
    For i = LBound(temp) To UBound(temp)
      For j = i To UBound(temp)
       If temp(j) < temp(i) Then
         Tempo = temp(j): temp(j) = temp(i): temp(i) = Tempo
       End If
      Next j
    Next i
    Me.Resultat.List = temp
End Sub

Private Sub UserForm_Initialize()
Set mondico = CreateObject("Scripting.Dictionary")
Me.Source.AddItem "Alain"
Me.Source.AddItem "Bernard"
Me.Source.AddItem "Charlie"
Me.Source.AddItem "Dany"
Me.Source.AddItem "Emile"
Me.Source.AddItem "Fleur"
End Sub

Transfert de 2 listBox dans une autre ListBox

Transfert 2 Listes

Private Sub UserForm_Initialize()
Me.ListePublic.RowSource = "A2:A" & [A65000].Row
Me.ListePrive.RowSource = "B2:B" & [B65000].Row
End Sub

Private Sub b_prend_Click()
  If Me.ListePublic.ListIndex <> -1 Then
      Me.Dest.AddItem Me.ListePublic
  End If
End Sub

Private Sub B_prendPrive_Click()
   If Me.ListePrive.ListIndex <> -1 Then
      Me.Dest.AddItem Me.ListePrive
    End If
End Sub

Private Sub B_moins_Click()
  If Me.Dest.ListIndex <> -1 And Me.Dest.ListIndex < Me.Dest.ListCount - 1 Then
     element = Me.Dest
     p = Me.Dest.ListIndex
     Me.Dest.AddItem element, p + 2
     Me.Dest.RemoveItem Me.Dest.ListIndex
     Me.Dest = element
  End If
End Sub

Private Sub B_plus_Click()
   If Me.Dest.ListIndex <> -1 And Me.Dest.ListIndex > 0 Then
      element = Me.Dest
      p = Me.Dest.ListIndex
      Me.Dest.AddItem element, p - 1
      Me.Dest.RemoveItem Me.Dest.ListIndex
      Me.Dest = element
   End If
End Sub

Private Sub ListePrive_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
B_prendPrive_Click
End Sub

Private Sub ListePublic_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
b_prend_Click
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
  End If
End Sub

Glisser/Déplacer 2 listBox

GlisserDéplacer

Private Sub ListBox1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  If Button = 1 Then
    Set d = New DataObject
    d.SetText ListBox1.Value & ":" & ListBox1.ListIndex
    Effect = d.StartDrag
  End If
End Sub

Private Sub ListBox2_BeforeDragOver(ByVal Cancel As MSForms.ReturnBoolean, ByVal Data As MSForms.DataObject, ByVal X As Single, ByVal Y As Single, ByVal DragState As Long, ByVal Effect As MSForms.ReturnEffect, ByVal Shift As Integer)
   Cancel = True
   Effect = 1
End Sub

Private Sub ListBox2_BeforeDropOrPaste(ByVal Cancel As MSForms.ReturnBoolean, ByVal Action As Long, ByVal Data As MSForms.DataObject, ByVal X As Single, ByVal Y As Single, ByVal Effect As MSForms.ReturnEffect, ByVal Shift As Integer)
  Cancel = True
  Effect = 1
  ListBox2.AddItem Split(Data.GetText, ":")(0)
  ListBox1.RemoveItem (Split(Data.GetText, ":")(1))
End Sub

Private Sub ListBox2_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  If Button = 1 Then
    Set d = New DataObject
    d.SetText ListBox2.Value & ":" & ListBox2.ListIndex
    Effect = d.StartDrag
  End If
End Sub

Private Sub ListBox1_BeforeDragOver(ByVal Cancel As MSForms.ReturnBoolean, ByVal Data As MSForms.DataObject, ByVal X As Single, ByVal Y As Single, ByVal DragState As Long, ByVal Effect As MSForms.ReturnEffect, ByVal Shift As Integer)
  Cancel = True
  Effect = 1
End Sub

Private Sub ListBox1_BeforeDropOrPaste(ByVal Cancel As MSForms.ReturnBoolean, ByVal Action As Long, ByVal Data As MSForms.DataObject, ByVal X As Single, ByVal Y As Single, ByVal Effect As MSForms.ReturnEffect, ByVal Shift As Integer)
Cancel = True
  Effect = 1
  ListBox1.AddItem Split(Data.GetText, ":")(0)
  ListBox2.RemoveItem (Split(Data.GetText, ":")(1))
End Sub

Exemples

Liste Transfert Simple

Liste Transfert

Liste Tranfert Trié

Liste Transfert 2 Listes