XL 2016 Déplacer une ligne dans listbox multicolonne

Andry · 13 Mai 2020

Bonjour à tous,

Cela fait un moment que j'essaie de trier une liste dans une listbox mais sans succès.

En faite, j'au un listbox multicolonne avec multiselect =1
Lorsque je sélectionne quelques lignes dans la listebox, je souhaite que ces lignes sélectionnées se retrouvent triées et en haut de la liste.
A chaque sélection de ligne, la liste se réorganise et toutes les lignes sélectionnés seront en haut. L'ordre n'est pas vraiment important mais surtout que les sélections soient en début de la liste.
J'ai essayé avec l’éventement mouseup!
Et ensuite, afficher à droite de la listbox des textbox en fonction du nombre de ligne sélectionné.
Merci d'avance!

fanch55 · 15 Mai 2020

Bonsoir, si je comprend bien, vous ne voulez aucun tri, vous désirez juste que ce que vous avez "pointé" dans la liste se retrouvent en haut de votre listbox , quel qu'en soit l'ordre ?

Andry · 16 Mai 2020

Bonjour,
Exact, l'ordre n'a pas d'importance
Merci

patricktoulon · 16 Mai 2020

bonjour
un petit exemple tout simple commenté

VB:

Private Sub ListBox1_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
 Dim tbl(), oldIndex&, Oneligne, i&, c&
   If Button = 1 Then ' pour que ca reste dans le contexte d'un click (bouton gauche de la souris)
   With ListBox1
        oldIndex = .ListIndex 'on repere l'index sélectionné
        Oneligne = Application.Index(.List, oldIndex + 1, 0) 'on récupe la ligne sélectionnée dans un array (1 dim)
        .RemoveItem (oldIndex) 'on suprime la ligne
         tbl = .List ' on récupere la list sans la ligne
        .Column = Oneligne 'on transpose l'array en colonne dans la listbox
        For i = 0 To UBound(tbl) 'on boucle sur la liste récupérée
            .AddItem tbl(i, 0) 'on ajoute l'item en colonne 0(la 1ère)
            For c = 1 To .ColumnCount - 1: .List(.ListCount - 1, c) = tbl(i, c): Next 'et on ajoute les colonnes suivante pour l'item
        Next
    End With
 End If
End Sub

Private Sub UserForm_Activate()
    With ListBox1
        .List = [A1:E10].Value
        .ColumnCount = 5
    End With
End Sub

fanch55 · 16 Mai 2020

Version pour un multiselect:

VB:

Option Explicit

Private Sub UserForm_Activate()
    ListBox1.List = [F1:G30].Value
End Sub

Private Sub ListBox1_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Dim I As Integer, J As Integer, S As Integer, Sel As Integer
    If Button = vbKeyLButton Then
        With ListBox1
           ' Détermination du nombre de lignes sélectionnées
           ' et stockage de celles-ci en début de Table
            S = -1
            ReDim Tbl(.ListCount - 1, .ColumnCount - 1)
            For I = 0 To .ListCount - 1
                If .Selected(I) Then
                    S = S + 1
                    For J = 0 To .ColumnCount - 1
                        Tbl(S, J) = .List(I, J)
                    Next J
                End If
            Next I
            Sel = S
                        
           ' Stockage des lignes non sélectionnées en suite de Table
           ' et déselection des lignes sélectionnées
            For I = 0 To .ListCount - 1
                If Not .Selected(I) Then
                    S = S + 1
                    For J = 0 To .ColumnCount - 1
                        Tbl(S, J) = .List(I, J)
                    Next J
                Else
                     .Selected(I) = False
                End If
            Next I
            
           ' Rechargement de toute la listbox avec la table
           ' ( attention: le .list = Tbl est fantaisiste )
            For I = 0 To UBound(Tbl, 1)
                For J = 0 To UBound(Tbl, 2)
                    .List(I, J) = Tbl(I, J)
                Next
            Next
            
            ' On Sélectionne autant de premières lignes
            ' que de lignes avaient été sélectionnées
             For I = 0 To Sel
                 .Selected(I) = True
             Next I
            
            ' on se positionne sur la première ligne de la listbox
            ' cette ligne est commentée, car c'est une option
            ' pouvant provoquer des interférences selon la vitesse du clic
            ' .TopIndex = 0
        End With
    End If

End Sub

Pas pris la même méthode que Patrick, les removeitem multiples au sein d'un multiselect sont assez capricieux .

patricktoulon · 17 Mai 2020

Bonjour fanch55
1° Private Sub ListBox1_MouseUp(B......

2° if .selectedt(i)........

????????????????????????????????????????????
n'est il pas contradictoire avec le fonctionnement du click gauche
je dis contradictoire , il faudrait plutôt dire inutile

me semble t il sauf nous avons des listbox différentes
que le mouseup s'applique des le premier car un click gauche select la ligne
alors quel est l’intérêt de compiler ????

patricktoulon · 17 Mai 2020

re
après si vraiment le removeitem est rédhibitoire pour toi et que tu prefere un "re list "
tu recompile le tableau d'un trait
if select(i) x=0 sinon x=x+1
avec une select single et click gauche

VB:

Private Sub UserForm_Activate()
    Dim plage As Range, C&, Cw$
    Set plage = [A1:G10]
    With ListBox1
        .List = plage.Value
        .ColumnCount = plage.Columns.Count
        For C = 1 To plage.Columns.Count
            Cw = Cw & plage.Cells(1, C).Width & IIf(C < plage.Columns.Count, ";", "")
        Next
        .ColumnWidths = Cw
    End With
End Sub
Private Sub ListBox1_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    Dim tbl, x1&
     With ListBox1
        x1 = 0
        ReDim tbl(.ListCount - 1, .ColumnCount - 1)
        For i = 0 To .ListCount - 1
            If .Selected(i) Then X = 0 Else x1 = x1 + 1: X = x1
            For C = 0 To .ColumnCount - 1
                tbl(X, C) = .List(i, C)
            Next C
        Next
        .List = tbl
    End With
End Sub

avec une multiselect il faut jouer click droit click gauche

VB:

Private Sub UserForm_Activate()
    Dim plage As Range, C&, Cw$
    Set plage = [A1:G10]
    With ListBox1
        .List = plage.Value
        .ColumnCount = plage.Columns.Count
        For C = 1 To plage.Columns.Count
            Cw = Cw & plage.Cells(1, C).Width & IIf(C < plage.Columns.Count, ";", "")
        Next
        .ColumnWidths = Cw
    End With
End Sub
Private Sub ListBox1_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    Dim tbl, x1&
    If Button = 2 Then    'si bouton droite
        With ListBox1
            X = -1
            ReDim tbl(.ListCount - 1, .ColumnCount - 1)
            For i = 0 To .ListCount - 1
                If .Selected(i) Then X = X + 1: For C = 0 To .ColumnCount - 1: tbl(X, C) = .List(i, C): Next C
            Next
            For i = 0 To .ListCount - 1
                If Not .Selected(i) Then X = X + 1: For C = 0 To .ColumnCount - 1: tbl(X, C) = .List(i, C): Next C
            Next
            .List = tbl
        End With
    End If
End Sub

fanch55 · 17 Mai 2020

patricktoulon à dit:
re
après si vraiment le removeitem est rédhibitoire pour toi et que tu prefere un "re list "
tu recompile le tableau d'un trait

Salut Pat,
Selon ce que j'en ai compris, le but n'est pas de remonter une seule ligne du tableau,
C'est de remonter toutes les lignes Sélectionnées en haut.
Ne travailler que sur une seule ligne comme le fait ton exemple est efficace mais montre ses limites quand il y a plus d'un select à prendre en compte .
On se retrouve avec des sélections qui n'ont plus rien à voir avec ce que qui l'était .

patricktoulon · 17 Mai 2020

re
regarde la version click droit post #7 elle n'est pas dans le fichier
chez moi j'ai testé c'est correct
je te la remet

VB:

Private Sub UserForm_Activate()
    Dim plage As Range, C&, Cw$
    Set plage = [A1:G10]
    With ListBox1
        .List = plage.Value
        .ColumnCount = plage.Columns.Count
        For C = 1 To plage.Columns.Count
            Cw = Cw & plage.Cells(1, C).Width & IIf(C < plage.Columns.Count, ";", "")
        Next
        .ColumnWidths = Cw
    End With
End Sub
Private Sub ListBox1_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    Dim tbl, x1&
    If Button = 2 Then    'si bouton droite
        With ListBox1
            X = -1
            ReDim tbl(.ListCount - 1, .ColumnCount - 1)
            For i = 0 To .ListCount - 1
                If .Selected(i) Then X = X + 1: For C = 0 To .ColumnCount - 1: tbl(X, C) = .List(i, C): Next C

            Next
            For i = 0 To .ListCount - 1
                If Not .Selected(i) Then X = X + 1: For C = 0 To .ColumnCount - 1: tbl(X, C) = .List(i, C): Next C
            Next
            .List = tbl
        End With
    End If
End Sub

après si je réfléchi un peu je me dis que la gestion multi select est inutile
car le select se fait par le click gauche
pourquoi attendre d'en avoir plusieurs
la seule chose qui le justifierait c'est la possibilité de desectionner une ligne avant renvoie en haut de liste
ca fait beaucoup je trouve pour quelques lignes

patricktoulon · 17 Mai 2020

re
et si tu veux que les items déplacés restent selectionnés

VB:

Private Sub ListBox1_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    Dim tbl, x1&
    If Button = 2 Then    'si bouton droite
        With ListBox1
            X = -1
            ReDim tbl(.ListCount - 1, .ColumnCount - 1)
            For i = 0 To .ListCount - 1
                If .Selected(i) Then X = X + 1: nb = nb + 1: For C = 0 To .ColumnCount - 1: tbl(X, C) = .List(i, C): Next C
            Next

            For i = 0 To .ListCount - 1
                If Not .Selected(i) Then X = X + 1: For C = 0 To .ColumnCount - 1: tbl(X, C) = .List(i, C): Next C
            Next
            .List = tbl
            For i = 1 To nb: .Selected(i - 1) = True: Next
        End With
    End If
End Sub

fanch55 · 17 Mai 2020

Testé ta dernière version :
Effectivement cela répond à l'attente .
Donc l'utilisateur sélectionne avec le clic droit et ramène en haut avec le clic gauche.
C'est viable et pas trop contraignant .
C'est au demandeur de se prononcer, mais on dirait que c'est une bouteille à la mer actuellement ....

patricktoulon · 17 Mai 2020

re

mais on dirait que c'est une bouteille à la mer actuellement ....

comme beaucoup
perso je verrais plus un menu contextuel "facon presque d'origine "
avec

envoyer en haut de liste
supprimer de la liste
copier dans...
etc....

le seul problème des popup vba commandbars c'est que le onaction ne peut pas appeler une sub qui se trouverait également dans le userform
c'est un de mes projets en cours que j'ai laissé de coté et qu'il faudrait aboutir
je te fait un exemple et tu travail de ton coté dessus si tu veux
le premier qui trouve partage
j'ai deja quelques idée que je n'ai jamais pris le temps de tester

patricktoulon · 17 Mai 2020

re
tiens si tu trouve

VB:

Private Sub UserForm_Activate()
    Dim plage As Range, C&, Cw$
    Set plage = [A1:G10]
    With ListBox1
        .List = plage.Value
        .ColumnCount = plage.Columns.Count
        For C = 1 To plage.Columns.Count
            Cw = Cw & plage.Cells(1, C).Width & IIf(C < plage.Columns.Count, ";", "")
        Next
        .ColumnWidths = Cw
    End With
End Sub
Private Sub ListBox1_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    Dim tbl, x1&
    If Button = 2 Then createmenu
End Sub

Public Function createmenu()
    On Error Resume Next
    CommandBars("menulist").Delete
    Err.Clear
    Set Barre = CommandBars.Add("Menulist", msoBarPopup, False, True)
    Set bout = Barre.Controls.Add(msoControlButton, 1, , , True)
    bout.Caption = "envoyer en haut de liste"
    bout.OnAction = "upToListe"     'not working
    'etc...
    'etc....

    Barre.ShowPopup
    On Error Resume Next
    CommandBars("menulist").Delete
    Err.Clear
 
End Function

Sub upToListe()
    MsgBox "coucou"
End Sub

fanch55 · 17 Mai 2020

Ma foi, à part jouer avec les vbcomponents :

VB:

Private Sub UserForm_Activate()
    Dim plage As Range, C&, Cw$
    Set plage = [A1:G10]
    With ListBox1
        .List = plage.Value
        .ColumnCount = plage.Columns.Count
        For C = 1 To plage.Columns.Count
            Cw = Cw & plage.Cells(1, C).Width & IIf(C < plage.Columns.Count, ";", "")
        Next
        .ColumnWidths = Cw
    End With
End Sub
Private Sub ListBox1_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    Dim tbl, x1&
    If Button = 2 Then createmenu
End Sub

Public Function createmenu()
    AddMacro "Feuil1", "UptoListe", _
            "Public Sub UpToListe", _
            "      " & Me.Name & ".UptoListe", _
            "End Sub"

    On Error Resume Next
    CommandBars("menulist").Delete
    Err.Clear
    Set Barre = CommandBars.Add("Menulist", msoBarPopup, False, True)
    Set bout = Barre.Controls.Add(msoControlButton, 1, , , True)
    bout.Caption = "envoyer en haut de liste"
    bout.OnAction = "Feuil1.UpToListe"     'not working
    'etc...
    'etc....
    Barre.ShowPopup
    On Error Resume Next
    CommandBars("menulist").Delete
    Err.Clear
 
End Function

Public Sub UpToListe()
    MsgBox "coucou"
End Sub

Sub AddMacro(Target As String, MacroName As String, ParamArray Line())
    With ActiveWorkbook.VBProject.VBComponents(Target).CodeModule
     On Error Resume Next
     X = .ProcStartLine(MacroName, 0)
     If Err > 0 Then .InsertLines .CountOfLines + 1, Join(Line, vbLf)
    End With
End Sub
Sub DelMacro(Target As String, MacroName As String)
    Dim Start As Integer, NLignes As Integer
    
    With ActiveWorkbook.VBProject.VBComponents(Target).CodeModule
        Start = .ProcStartLine(MacroName, 0)
        NLignes = .ProcCountLines(MacroName, 0)
        .DeleteLines Start, NLignes
    End With
End Sub
Private Sub UserForm_Terminate()
    DelMacro "Feuil1", "UptoListe"
End Sub

patricktoulon · 17 Mai 2020

re
Ah!!.. un peu lourd mais c'est pas mal du tout, j'y avais pensé mais je n'avais pas osé
penser a la destruction a la fermeture de l'userform
ben tu y a pensé nickel
ca fait une solution

XL 2016 Déplacer une ligne dans listbox multicolonne

Andry

XLDnaute Junior

fanch55

XLDnaute Barbatruc

Andry

XLDnaute Junior

patricktoulon

XLDnaute Barbatruc

fanch55

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

Pièces jointes

fanch55

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

fanch55

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

fanch55

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

Discussions similaires