Transfert liste

Accueil

ListeTransfert Simple
Liste transfert Fichiers
ListeTransfert Trié
Glisser/Déplacer

Liste transfert simple

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

Liste Transfert Simple

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

avec Multi-sélection et Multicolonnes

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

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


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

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