XL 2016 Déplacer une ligne dans listbox multicolonne

[Andry]

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]

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]

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

 

[patricktoulon]

bonjour
un petit exemple tout simple commenté

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]

Version pour un multiselect:

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]

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]

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

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

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]

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]

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

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]

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

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]

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]

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

1. envoyer en haut de liste
2. supprimer de la liste
3. copier dans...
4. 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]

re
tiens si tu trouve

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]

Ma foi, à part jouer avec les vbcomponents :

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]

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