Trier une listbox

**goninph** · 27/12/2019, 16h09

Bonjour,

Comment faire pour trier cette listbox par ordre alphabétique ?

Merci pour votre aide
Meilleures salutations
Philippe

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
Option Explicit
Dim f, choix(), Rng, Ncol
Dim n As Variant
Dim k As Variant
Private Sub UserForm_Initialize()
Dim DerniereLigne As Long
Dim c As Variant
Dim tmp As Variant
Dim TblTmp()
On Error GoTo FichierVide
    Set f = ActiveSheet
    If ActiveSheet.FilterMode = True Then ActiveSheet.ShowAllData 'Enlever les filtres
    DerniereLigne = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
    Set Rng = Range(Cells(25, 1), Cells(DerniereLigne, 1))
    n = 0
    For Each c In Rng.SpecialCells(xlCellTypeConstants, 23)
        n = n + 1
        ReDim Preserve TblTmp(1 To 2, 1 To n)
        TblTmp(1, n) = c.Address
        On Error Resume Next
        tmp = Replace(Replace(c.Value, Chr(13), "  -  "), Chr(10), "")
        tmp = c.Value
        On Error GoTo 0
        TblTmp(2, n) = tmp
        ReDim Preserve choix(1 To n)
        choix(n) = choix(n) & TblTmp(1, n) & " * " & TblTmp(2, n)
    Next c
    Ncol = 2
    Me.ListBox1.List = Application.Transpose(TblTmp)
    Me.TextBox1.SetFocus 'Place le curseur dans la textbox
    Me.Label_Nombre_trouve.Caption = "Trouvé : " & n + 1
FichierVide:
End Sub
Private Sub TextBox1_Change()
Dim Mots As Variant
Dim Tbl As Variant
Dim i As Variant
Dim a As Variant
   On Error Resume Next 'Evite le beug lorsque l'on saisi un espace pour commencer
   If Me.TextBox1 <> "" Then
        Mots = Split(Trim(Me.TextBox1), " ")
        Tbl = choix
        For i = LBound(Mots) To UBound(Mots)
            Tbl = Filter(Tbl, Mots(i), True, vbTextCompare)
        Next i
        If UBound(Tbl) > -1 Then
                n = 0: Dim b()
            For i = LBound(Tbl) To UBound(Tbl)
                a = Split(Tbl(i), "*")
                n = n + 1: ReDim Preserve b(1 To Ncol, 1 To n)
                For k = 1 To Ncol
                    b(k, i + 1) = a(k - 1)
                Next k
            Next i
            If n > 0 Then
                ReDim Preserve b(1 To Ncol, 1 To n + 1)
                Me.ListBox1.List = Application.Transpose(b)
                Me.ListBox1.RemoveItem n
            End If
        Else
            Me.ListBox1.Clear
        End If
        Me.Label_Nombre_trouve.Caption = "Trouvé : " & UBound(Tbl) + 1
    Else
        UserForm_Initialize
    End If
End Sub
Private Sub ListBox1_Click()
Dim Filtre_Val_Cellule_Active As Variant
Dim adr As Variant
Dim Ligne As Long
    For k = 0 To Ncol - 1
      Me("TextBox" & k + 2) = Me.ListBox1.Column(k)
    Next k
    adr = Me.ListBox1
    Ligne = Range(adr).Row 'Numéro de la ligne
    Rows(Ligne).Select 'Déplace le document pour rendre visible l'étiquette
    'N° Projet_eta - filtre la valeur de la cellule active
    Filtre_Val_Cellule_Active = Cells(Ligne, 3).Value
    ActiveSheet.Range("A25").AutoFilter Field:=3, Criteria1:="=" & Filtre_Val_Cellule_Active
    ActiveWindow.ScrollRow = 1 'Deplace le focus de l'écran sur la ligne 1
End Sub
Private Sub CommandButton1_Click()
Unload Me
End Sub

**Jean-Philippe André** · 27/12/2019, 16h43

Salut,

le tri à bulles ferait l'affaire ?

Sinon tu peux voir les grandes avancées faites avec les arrays :
https://didier-gonard.developpez.com...bleau-vba/#LIX

**boisgontierjacques** · 27/12/2019, 17h40

Bonsoir,

Exemple simple.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
Option Compare Text
Private Sub UserForm_Initialize()
 Set f = Sheets("BD")
 tbl = f.Range("A2:C" & f.[A65000].End(xlUp).Row).Value
 Tri tbl, LBound(tbl), UBound(tbl), 1
 Me.ListBox1.List = tbl
End Sub
 
Private Sub TriVille_Click()
  tbl = Me.ListBox1.List
  Tri tbl, LBound(tbl), UBound(tbl), 1
  Me.ListBox1.List = tbl
End Sub
 
Private Sub TriNom_Click()
  tbl = Me.ListBox1.List
  Tri tbl, LBound(tbl), UBound(tbl), 0
  Me.ListBox1.List = tbl
End Sub
 
Sub Tri(a, gauc, droi, colTri)             ' Quick sort
 ref = a((gauc + droi) \ 2, colTri)
 g = gauc: d = droi
 Do
     Do While a(g, colTri) < ref: g = g + 1: Loop
     Do While ref < a(d, colTri): d = d - 1: Loop
     If g <= d Then
       For c = LBound(a, 2) To UBound(a, 2)
         temp = a(g, c): a(g, c) = a(d, c): a(d, c) = temp
       Next
       g = g + 1: d = d - 1
     End If
 Loop While g <= d
 If g < droi Then Call Tri(a, g, droi, colTri)
 If gauc < d Then Call Tri(a, gauc, d, colTri)
End Sub

Boisgontier

**Pierre Fauconnier** · 27/12/2019, 17h58

Salut Philippe,

Perso, je trierais la source et je rechargerais la listbox.

Dans un module standard, je placerais l'appel et l'initialisation de la listbox, ainsi que la procédure de tri.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Sub test()
  SortTable xlAscending
  With UserForm1
    .ListBox1.List = Range("t_Contacts").Value
    .Show
  End With
End Sub
 
Sub SortTable(Order As XlSortOrder)
  With Range("t_Contacts").ListObject.Sort
    .SortFields.Clear
    .SortFields.Add Key:=Range("t_Contacts[Nom]"), Order:=Order
    .Apply
  End With
End Sub

Sur les boutons de modifications du tri de la listbox, je placerais le code qui retrie la plage avec les outils d'Excel et qui rafraichirait la liste.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
Private Sub btnAtoZ_Click()
  SortTable xlAscending
  ListBox1.List = Range("t_Contacts").Value
End Sub
 
Private Sub btnZtoA_Click()
  SortTable xlDescending
  ListBox1.List = Range("t_Contacts").Value
End Sub

Ca n'a pour moi aucun sens de retrier en passant pas un array dans l'Initialize du userform. Perso, je n'utiliserais pas Initialize pour le faire. initialize devrait, dans les faits, n'être que très rarement utilisé, voire jamais. Ca rend plus compliqué l'évolution de ton appli et ça verrouille tes choix de départ. Il est préférable d'initialiser le userform par du code se trouvant en dehors de lui, c'est-à-dire dans une procédure standard comme illustré ci-dessus. Normalement, une autre architecture, plus solide et plus en accord avec la POO devrait être mise en place (un userform est un objet et ne devrait donc pas avoir besoin d'un truc externe à lui pour fonctionner), mais dans le cadre d'un projet de moyenne envergure avec Excel et VBA, ce que je propose est déjà très correct.

En 2019, ça n'a pas de sens de travailler avec des plages classiques, qui plus est limitées par code à 65000 lignes

(au fait, pourquoi pas 65536 ou 63000 ou 58000?) et des trucs du genre f.[a65000].End(xlup). A part faire "langage d'initié" parce que ça fait bien, [A65000] sert juste à ne pas taper Range("a65000") et au passage à ne pas bénéficier de la saisie semi-automatique, si tu déplaces ta plage, ailleurs sur la feuille ou sur une autre feuille, ton code plantera, alors que les références structurées et les ListObject amènent la stabilité requise. Je ne comprends pas comment on propose encore du code "XL2003" en 2019

**goninph** · 31/12/2019, 12h04

Salut Pierre,

À quoi correspond : Range("t_Contacts[Nom]") ?

Merci pour ton aide
Philippe

**Pierre Fauconnier** · 31/12/2019, 12h18

Salut Philippe,

A la référence structurée d'un... tableau structuré (Voir mon tuto à ce sujet).

L'utilisation des tableaux structurés simplifie ton Excel ET ton vba. Il me semble aberrant, en 2019, que les codes proposés sur le forum fassent toujours appel aux constructions "classiques" d'Excel.

**goninph** · 31/12/2019, 16h33

Salut Pierre,

Merci pour ces infos et le super Tuto. Je vais pouvoir adapter mon code.

Encore milles mercis à tous pour l'aide apportée durant cette année 2019.

Je vous souhaite tous mes meilleurs vœux pour cette nouvelle année 2020.

Meilleures salutations
Philippe

**Pierre Fauconnier** · 31/12/2019, 16h56

Meilleurs voeux à toi aussi Philippe. Au plaisir de te croiser sur nos forums en 2020 😉

**goninph** · 05/01/2020, 19h40

Bonne année 2020 à tous.

Voici le code qui fonctionne pour mon cas précis, merci à Jacques.

Je ne peux pas adapter les conseils de Pierre pour ce cas précis car il n'y a pas de tableau et je ne peux pas en créer un, mais ils me seront très utile pour mes futures listes.

Il s'agit d'une simple recherche dans la colonne "A" qui contient du texte concaténant certaines cellules de la même ligne mais pas sur toutes les lignes, il y a beaucoup de cellule vide sur la colonne "A".

J'ai également découvert la fonction : SpecialCells(xlCellTypeFormulas) ce qui m'a permis de pouvoir enfin lire les cellules concaténées et surtout de ne pas lister toutes les cellules vides dans la Listbox.

Merci à tous pour vos précieux conseils
Meilleures salutations
Philippe

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
Option Explicit
Option Compare Text
Dim f, choix(), Rng, Ncol
Dim n As Variant
Dim k As Variant
Private Sub UserForm_Initialize()
Dim DerniereLigne As Long
Dim c As Variant
Dim tmp As Variant
Dim TblTmp()
Dim Tbl As Variant
On Error GoTo FichierVide
    Set f = ActiveSheet
    If ActiveSheet.FilterMode = True Then ActiveSheet.ShowAllData 'Enlever les filtres
    DerniereLigne = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
    Set Rng = Range(Cells(25, 1), Cells(DerniereLigne, 1))
    n = 0
    For Each c In Rng.SpecialCells(xlCellTypeFormulas) 'Recherche que les cellules avec du texte concaténé et évite les cellules vides dans la Listbox
        n = n + 1
        ReDim Preserve TblTmp(1 To 2, 1 To n)
        TblTmp(1, n) = c.Address
        tmp = c.Value
        TblTmp(2, n) = tmp
        ReDim Preserve choix(1 To n)
        choix(n) = choix(n) & TblTmp(1, n) & " * " & TblTmp(2, n)
    Next c
    Ncol = 2
    Me.ListBox1.List = Application.Transpose(TblTmp)
    Call Trier_Colonne_1
    Me.TextBox1.SetFocus 'Place le curseur dans la textbox
    Me.Label_Nombre_trouve.Caption = "Trouvé : " & n '+ 1
FichierVide:
End Sub
Private Sub TextBox1_Change()
Dim Mots As Variant
Dim Tbl As Variant
Dim i As Variant
Dim a As Variant
   On Error Resume Next 'Evite le beug lorsque l'on saisi un espace pour commencer
   If Me.TextBox1 <> "" Then
        Mots = Split(Trim(Me.TextBox1), " ")
        Tbl = choix
        For i = LBound(Mots) To UBound(Mots)
            Tbl = Filter(Tbl, Mots(i), True, vbTextCompare)
        Next i
        If UBound(Tbl) > -1 Then
                n = 0: Dim b()
            For i = LBound(Tbl) To UBound(Tbl)
                a = Split(Tbl(i), "*")
                n = n + 1: ReDim Preserve b(1 To Ncol, 1 To n)
                For k = 1 To Ncol
                    b(k, i + 1) = a(k - 1)
                Next k
            Next i
            If n > 0 Then
                ReDim Preserve b(1 To Ncol, 1 To n + 1)
                Me.ListBox1.List = Application.Transpose(b)
                Me.ListBox1.RemoveItem n
            End If
        Else
            Me.ListBox1.Clear
        End If
        Call Trier_Colonne_1
        Me.Label_Nombre_trouve.Caption = "Trouvé : " & UBound(Tbl) + 1
    Else
        UserForm_Initialize
    End If
End Sub
Private Sub ListBox1_Click()
Dim Filtre_Val_Cellule_Active As Variant
Dim adr As Variant
Dim Ligne As Long
    adr = Me.ListBox1
    Ligne = Range(adr).Row 'Numéro de la ligne
    Rows(Ligne).Select 'Déplace le document pour rendre visible l'étiquette
    'N° Projet_eta - filtre la valeur de la cellule active
    Filtre_Val_Cellule_Active = Cells(Ligne, 3).Value
    ActiveSheet.Range("A25").AutoFilter Field:=3, Criteria1:="=" & Filtre_Val_Cellule_Active
    ActiveWindow.ScrollRow = 1 'Deplace le focus de l'écran sur la ligne 1
End Sub
Private Sub Trier_Colonne_1()
Dim a()
Dim NbCol As Variant
    a = Me.ListBox1.List
    NbCol = UBound(a, 2) - LBound(a, 2) + 1
    Call tri(a(), LBound(a), UBound(a), NbCol, 1) '1 = N° de colonne à trier
    Me.ListBox1.List = a
End Sub
Sub tri(a(), gauc, droi, NbCol, colTri) ' Quick sort
Dim ref, g, d, c, temp As Variant
 ref = a((gauc + droi) \ 2, colTri)
 g = gauc: d = droi
 Do
     Do While a(g, colTri) < ref: g = g + 1: Loop
     Do While ref < a(d, colTri): d = d - 1: Loop
     If g <= d Then
       For c = 0 To NbCol - 1
         temp = a(g, c): a(g, c) = a(d, c): a(d, c) = temp
       Next
       g = g + 1: d = d - 1
     End If
 Loop While g <= d
 If g < droi Then Call tri(a, g, droi, NbCol, colTri)
 If gauc < d Then Call tri(a, gauc, d, NbCol, colTri)
End Sub
Private Sub BT_Annuler_Click()
    Unload Me
End Sub

Trier une listbox

Macros et VBA Excel

Vue hybride

Discussions similaires

Partager

Partager