Accueil

Liste triée dans un tableau
Tri ListBox 1 colonne croissant ou décroissant
Fonction de tri ListBox
Formulaire de consultation & modification trié
Tri dans le tableur
Liste Triée sans tableau
Fusion sans doublons triée de 2 champs pour ComboBox
Tri dans une feuille temporaire
Liste triée sans vide avec Dictionary
Tri ListBox multiColonnes rapide
Tri multi-colonnes multicritères
Tri ListBox Multi colonnes
TRi ListBox Multi-colonnes croissant ou décroissant

Liste triée sans liste intermédiaire avec tableau

Liste Triée
Liste Triée2

Option Compare Text
Private Sub UserForm_Initialize()
  Set f = Sheets("BD")
  temp = Application.Transpose(Range(f.[a2], f.[a2].End(xlDown)).Value)
  Tri temp, LBound(temp), UBound(temp)
  Me.ComboBox1.List = temp
  SendKeys "{F4}"
End Sub

Sub Tri(a, gauc, droi) ' Quick sort
  ref = a((gauc + droi) \ 2)
  g = gauc: d = droi
  Do
    Do While a(g) < ref: g = g + 1: Loop
    Do While ref < a(d): d = d - 1: Loop
    If g <= d Then
       temp = a(g): a(g) = a(d): a(d) = temp
       g = g + 1: d = d - 1
    End If
  Loop While g <= d
  If g < droi Then Call Tri(a, g, droi)
  If gauc < d Then Call Tri(a, gauc, d)
End Sub

Pour un tri décroissant

Do While a(g) > ref: g = g + 1: Loop
Do While ref > a(d): d = d - 1: Loop

Tri ListBox 1 colonne croissant ou décroissant

Sur cet exemple, nous trions un ListBox en ordre croissant ou décroissant.

a=ListBox1.List retourne un tableau a(0 to ListCount-1,0 To 0)

Liste Triée Croissant_Décroissant

Option Compare Text
Private Sub UserForm_Initialize()
  Set f = Sheets("BD")
  Dim temp()
  temp = f.Range("B2:B" & f.[B65000].End(xlUp).Row).Value
  Tri temp, LBound(temp), UBound(temp), 0 ' 1:Croissant 0:décroissant
  Me.ListBox1.List = temp
End Sub

Private Sub B_croissant_Click()
  Dim temp()
  temp = Me.ListBox1.List
  Tri temp, LBound(temp), UBound(temp), 1 ' 1:Croissant 0:décroissant
  Me.ListBox1.List = temp
End Sub

Private Sub B_décroissant_Click()
  Dim temp()
  temp = Me.ListBox1.List
  Tri temp, LBound(temp), UBound(temp), 0 ' 1:Croissant 0:décroissant
  Me.ListBox1.List = temp
End Sub

Sub Tri(a(), gauc, droi, ordre) ' Quick sort Ordre=1 Croissant/Ordre=0:décroissant
  col = UBound(a, 2)
  ref = a((gauc + droi) \ 2, col)
  g = gauc: d = droi
  Do
    If ordre = 1 Then
       Do While a(g, col) < ref: g = g + 1: Loop
       Do While ref < a(d, col): d = d - 1: Loop
    Else
       Do While a(g, col) > ref: g = g + 1: Loop
       Do While ref > a(d, col): d = d - 1: Loop
    End If
    If g <= d Then
      temp = a(g, col): a(g, col) = a(d, col): a(d, col) = temp
      g = g + 1: d = d - 1
    End If
    Loop While g <= d
    If g < droi Then Call Tri(a, g, droi, ordre)
    If gauc < d Then Call Tri(a, gauc, d, ordre)
End Sub

Fonction de tri d'une listbox:ListSort()

Tri une listBox ou une combobox existante

Tri ListBox
Tri ListBox Multi-colonnes

Private Sub UserForm_Initialize()
  Set f = Sheets("BD")
  Set champ = f.Range("A2:A" & f.[A65000].End(xlUp).Row)
  For Each c In champ
     If c <> "" Then Me.ListBox1.AddItem c
  Next c
  Me.ListBox1.List = ListSort(Me.ListBox1.List)
End Sub

Function ListSort(b)
   Call Tri(b, LBound(b), UBound(b))
   ListSort = b
End Function

Sub Tri(a, gauc, droi) ' Quick sort
  If UBound(a, 2) = 9 Then p = 0 Else p = UBound(a, 2)
  ref = a((gauc + droi) \ 2, p)
  g = gauc: d = droi
  Do
    Do While a(g, p) < ref: g = g + 1: Loop
    Do While ref < a(d, p): d = d - 1: Loop
    If g <= d Then
       temp = a(g, p): a(g, p) = a(d, p): a(d, p) = temp
       g = g + 1: d = d - 1
    End If
  Loop While g <= d
  If g < droi Then Call Tri(a, g, droi)
  If gauc < d Then Call Tri(a, gauc, d)
End Sub

Formulaire de consultation/modification trié

Form Consultation Modification Trié

Le ComboBox a 2 colonnes. Dans la seconde colonne, nous stockons le no d'enregistrement.

Dim f, ligneEnreg
Private Sub UserForm_Initialize()
  Set f = Sheets("bd")
  Me.Service.List = Array("Etudes", "Informatique", "Marketing", "Production")
  Me.Ville.List = Array("Boulogne", "Lyon", "Paris", "Versailles")
  a = f.Range("B2:C" & f.[B65000].End(xlUp).Row)     ' tableau a(n,2) pour rapidité
  For i = LBound(a) To UBound(a)
    If a(i, 1) <> "" Then a(i, 2) = i + 1                        ' No enreg dans la 2e colonne
  Next i
  '-------------avec tri---------------
  Call Tri2Col(a, LBound(a), UBound(a))
  Me.ChoixNom.List = a
  Me.ChoixNom.ListIndex = 0
End Sub

Private Sub ChoixNom_Click()
  ligneEnreg = Me.ChoixNom.Column(1) ' No enreg dans la 2e colonne
  Me.nom = f.Cells(ligneEnreg, 2)
  Me.Marié = f.Cells(ligneEnreg, 3)
  Me.Date_naissance = f.Cells(ligneEnreg, 4)
  Me.Service = f.Cells(ligneEnreg, 5)
  Me.Ville = f.Cells(ligneEnreg, 6)
  Me.Salaire = f.Cells(ligneEnreg, 7)
  '-- civilité
  For Each c In Me.Civilité.Controls
     If f.Cells(ligneEnreg, "a") = c.Caption Then c.Value = True
  Next c
End Sub

Liste triée (tri dans le tableur)

FormTriTableur

Nom de champ
Liste =DECALER(BD!$A$2;;;NBVAL(BD!$A:$A)-1)

Private Sub UserForm_Initialize()
  [liste].Sort Key1:=[liste]
  Me.ComboBox1.List = [liste].Value
  Me.ComboBox1.ListIndex = 0        'positionnement sur le premier élément
End Sub

ou sans nom de champ

Private Sub UserForm_Initialize()
  Set f = Sheets("BD")
  f.[A:A].Sort Key1:=f.[A:A], Header:=xlGuess
  Me.ComboBox1.List = Range(f.[A2], f.[A2].End(xlDown)).Value
  Me.ComboBox1.ListIndex = 0 'positionnement sur le premier élément
End Sub

Tri dans une feuille temporaire

FormTriTableur2

Private Sub UserForm_Initialize()
  Set f = Sheets("BD")
  Me.ComboBox1.List = Range(f.[A2], f.[A2].End(xlDown)).Value
  Application.ScreenUpdating = False
  Sheets.Add
  [A1].Resize(ComboBox1.ListCount) = ComboBox1.List
  [A1:A10000].Sort Key1:=[A:A], Order1:=xlAscending, Header:=xlGuess
  Me.ComboBox1.List = [A1].Resize(ComboBox1.ListCount).Value
  Application.DisplayAlerts = False
  ActiveSheet.Delete
  Application.ScreenUpdating = True
End Sub

Liste triée sans liste intermédiaire et sans tableau

Créer un nom de champ dynamique.

Liste4 =DECALER($B$2;;;NBVAL($B:$B)-1)

Les options sont insérées directement dans la liste à la bonne position.

Private Sub UserForm_Initialize()
 ' trié
 For i = 1 To Range("liste4").Count
    j = 0
    Do While Range("liste4")(i) > Me.ListBox1.List(j) And j < Me.ListBox1.ListCount - 1
       j = j + 1
    Loop
    Me.ListBox1.AddItem Range("liste4")(i), _
      IIf(Range("liste4")(i) > Me.ListBox1.List(Me.ListBox1.ListCount - 1), j + 1, j)
 Next i
End Sub

Liste triée sans vides

ListeTriéeSanVides

Option Compare Text
Private Sub UserForm_Initialize()
  Dim temp()
  Set f = Sheets("BD")
  Set MonDico = CreateObject("Scripting.Dictionary")
  For Each c In f.Range("A2:A" & f.[A65000].End(xlUp).Row)
    If c.Value <> "" Then MonDico.Item(c.Value) = c.Value
  Next c
  temp = MonDico.items
  Call tri(temp, LBound(temp), UBound(temp))
  Me.ComboBox1.List = temp
End Sub

Sub tri(a(), gauc, droi) ' Quick sort
   ref = a((gauc + droi) \ 2)
   g = gauc: d = droi
   Do
     Do While a(g) < ref: g = g + 1: Loop
     Do While ref < a(d): d = d - 1: Loop
     If g <= d Then
       temp = a(g): a(g) = a(d): a(d) = temp
       g = g + 1: d = d - 1
     End If
   Loop While g <= d
   If g < droi Then Call tri(a, g, droi)
   If gauc < d Then Call tri(a, gauc, d)
End Sub

Liste sans doublons triée

On veut une liste sans doublons triée.

FormComboTrié
FormComboTriéOrdreQte

Option Compare Text
Private Sub UserForm_Initialize()
  Set f = Sheets("BD")
  Set MonDico = CreateObject("Scripting.Dictionary")
  For Each c In f.Range("A1:F8")
    If c.Value <> "" Then MonDico.Item(c.Value) = c.Value
  Next c
  temp = MonDico.items
  Call tri(temp, LBound(temp), UBound(temp))
  Me.ComboBox1.List = temp
End Sub

Sub tri(a, gauc, droi) ' Quick sort
  ref = a((gauc + droi) \ 2)
  g = gauc: d = droi
  Do
    Do While a(g) < ref: g = g + 1: Loop
    Do While ref < a(d): d = d - 1: Loop
    If g <= d Then
      temp = a(g): a(g) = a(d): a(d) = temp
      g = g + 1: d = d - 1
    End If
  Loop While g <= d
  If g < droi Then Call tri(a, g, droi)
  If gauc < d Then Call tri(a, gauc, d)
End Sub

Alimentation d'un combobox trié avec ArrayList

Form Liste triée ArrayList

Option Compare Text
Private Sub UserForm_Initialize()
  Set f = Sheets("bd")
  Set AL = CreateObject("System.Collections.ArrayList")
  a = f.Range("a2:a" & f.[A65000].End(xlUp).Row).Value
  For i = LBound(a) To UBound(a)
    If a(i, 1) <> "" Then AL.Add a(i, 1)
  Next i
  AL.Sort
  Me.ComboBox1.List = AL.ToArray
End Sub

Alimentation d'un combobox trié sans doublons avec ArrayList

La colonne 4 de la BD contient des noms de villes

Tri SortedList

Private Sub UserForm_Initialize()
  Set f = Sheets("bd2")
  a = f.Range("A2:E" & f.[A65000].End(xlUp).Row).Value
  Set AL = CreateObject("System.Collections.Arraylist")
  For i = LBound(a) To UBound(a)
    If Not AL.contains(a(i, 4)) Then AL.Add a(i, 4)
  Next i
  AL.Sort
  Me.ComboBox1.List = AL.toarray
End Sub

Fusion sans doublons triée de 2 champs pour ComboBox

Form Fusion sans doublons triée de 2 champs

Private Sub UserForm_Initialize()
  Set f = Sheets("bd")
  a = f.Range("A2:A" & f.[A65000].End(xlUp).Row)
  b = f.Range("E2:E" & f.[E65000].End(xlUp).Row)
  Me.ComboBox1.List = Fusion(a, b)
End Sub

Function Fusion(tab1, tab2)
  Application.Volatile
  Dim temp()
  Set d = CreateObject("Scripting.Dictionary")
  For Each c In tab1
     If c <> "" And c <> 0 Then tmp = c: d(tmp) = ""
  Next c
  For Each c In tab2
    If c <> "" And c <> 0 Then tmp = c: d(tmp) = ""
  Next c
  temp = d.keys
  Call tri(temp(), LBound(temp), UBound(temp))
  Fusion = Application.Transpose(temp)
End Function

Tri ListBox MultiColonnes rapide

TriListBox rapide

Private Sub UserForm_Initialize()
  Set f = Sheets("TriListBox")
  Me.ListBox1.List = f.Range("A2:C" & f.[A65000].End(xlUp).Row).Value
End Sub

Private Sub LTriNom_Click()
  Dim a()
  a = Me.ListBox1.List
  Tri a(), LBound(a), UBound(a), 0
  Me.ListBox1.List = a
  Me.LTriNom.ForeColor = vbRed
  Me.LTriVille.ForeColor = vbBlack
  Me.LCP.ForeColor = vbBlack
End Sub

Private Sub LTriVille_Click()
  Dim a()
  a = Me.ListBox1.List
  Tri a(), LBound(a), UBound(a), 1
  Me.ListBox1.List = a
  Me.LTriNom.ForeColor = vbBlack
  Me.LTriVille.ForeColor = vbRed
  Me.LCP.ForeColor = vbBlack
End Sub

Sub Tri(a(), gauc, droi, colTri) ' Quick sort
  colD = LBound(a, 2): colF = UBound(a, 2)
  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 = colD To colF
         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

Private Sub B_recup_Click()
Sheets("Result").[A2].Resize(Me.ListBox1.ListCount, 3) = Me.ListBox1.List
End Sub

Avec tri dans le tableur

Private Sub LTriNom_Click()
  With Sheets("Feuil1")
     .[A1:C10000].Sort Key1:=.[A2], Order1:=xlAscending, Header:=xlGuess
     Me.ListBox1.List = .Range("A2:C" & .[A65000].End(xlUp).Row).Value
  End With

End Sub

Private Sub LTriVille_Click()
   With Sheets("Feuil1")
     .[A1:C10000].Sort Key1:=.[B2], Order1:=xlAscending, Header:=xlGuess
     Me.ListBox1.List = .Range("A2:C" & .[A65000].End(xlUp).Row).Value
   End With
End Sub

Tri ListBox multi-colonnes dans une feuille temporaire

Private Sub LTriNom_Click()
  Application.ScreenUpdating = False
  Sheets.Add
  [A1].Resize(ListBox1.ListCount, 3) = ListBox1.List
  [A1].Resize(ListBox1.ListCount, 3).Sort Key1:=[A:A], Order1:=xlAscending, Header:=xlGuess
  Me.ListBox1.List = [A1].Resize(ListBox1.ListCount, 3).Value
  Application.DisplayAlerts = False
  ActiveSheet.Delete
  Me.LTriNom.ForeColor = vbRed
  Me.LTriVille.ForeColor = vbBlack
  Me.LCP.ForeColor = vbBlack
End Sub

Private Sub LTriVille_Click()
  Application.ScreenUpdating = False
  Sheets.Add
  [A1].Resize(ListBox1.ListCount, 3) = ListBox1.List
  [A1].Resize(ListBox1.ListCount, 3).Sort Key1:=[B:B], Order1:=xlAscending, Header:=xlGuess
  Me.ListBox1.List = [A1].Resize(ListBox1.ListCount, 3).Value
  Application.DisplayAlerts = False
  ActiveSheet.Delete
  Me.LTriNom.ForeColor = vbBlack
  Me.LTriVille.ForeColor = vbRed
  Me.LCP.ForeColor = vbBlack
End Sub

ListBox Multi-colonnes trié Multi-critères avec index

Ci dessous, nous trions par Nom+ville ou Ville+Nom

TriListBoxMultiCritères Index
TriListBoxMultiCritèresNomPrénom index

Private Sub UserForm_Initialize()
  With Sheets("TriListBox")
      Me.ListBox1.List = .Range("A2:C" & .[A65000].End(xlUp).Row).Value
  End With
End Sub

Private Sub LTriNom_Click()
  Dim clé() As String, index() As Long
  Dim a(), b()
  a = Me.ListBox1.List
  ReDim b(LBound(a) To UBound(a), LBound(a, 2) To UBound(a, 2))
  ReDim clé(LBound(a) To UBound(a, 1))
  ReDim index(LBound(a) To UBound(a, 1))
  For i = LBound(a) To UBound(a, 1)
     clé(i) = a(i, 0) & a(i, 1): index(i) = i
  Next i
  Tri clé(), index(), LBound(a), UBound(clé)
  For lig = LBound(clé) To UBound(clé)
     For col = LBound(a, 2) To UBound(a, 2): b(lig, col) = a(index(lig), col): Next col
  Next lig
  Me.ListBox1.List = b
  Me.LTriNom.ForeColor = vbRed
  Me.LTriVille.ForeColor = vbBlack
  Me.LCP.ForeColor = vbBlack
End Sub

Sub Tri(clé() As String, index() As Long, gauc, droi) ' Quick sort
  ref = clé((gauc + droi) \ 2)
  g = gauc: d = droi
  Do
    Do While clé(g) < ref: g = g + 1: Loop
    Do While ref < clé(d): d = d - 1: Loop
    If g <= d Then
      temp = clé(g): clé(g) = clé(d): clé(d) = temp
      temp = index(g): index(g) = index(d): index(d) = temp
      g = g + 1: d = d - 1
    End If
  Loop While g <= d
  If g < droi Then Call Tri(clé, index, g, droi)
  If gauc < d Then Call Tri(clé, index, gauc, d)
End Sub

Tri multi-colonnes d'une listbox

Form Tri ListBox multi-colonnes Alpha ou Num

Option Compare Text
Private Sub OptionButton1_Click()
  Dim a()
  a = Me.ListBox1.List
  Tri a(), LBound(a), UBound(a), 0
  Me.ListBox1.List = a
End Sub

Private Sub OptionButton2_Click()
  Dim a()
  a = Me.ListBox1.List
  Tri a(), LBound(a), UBound(a), 1
  Me.ListBox1.List = a
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

Private Sub UserForm_Initialize()
ListBox1.List = Range("A2:B" & Range("a65000").End(xlUp).Row).Value
End Sub

Tri multi-colonnes d'une listbox en ordre croissant ou décroissant

Form Tri ListBox multi-colonnes Croissant ou Décroissant
Form Tri ListBox Alpha ou Num multi-critères Index

Option Compare Text
Private Sub B_croissant_Click()
  Dim a()
  a = Me.ListBox1.List
  QuickOrdre a(), LBound(a), UBound(a), 1, True
  Me.ListBox1.List = a
End Sub

Private Sub B_décroissant_Click()
  Dim a()
  a = Me.ListBox1.List
  QuickOrdre a(), LBound(a), UBound(a), 1, False
  Me.ListBox1.List = a
End Sub

Sub QuickOrdre(a(), gauc, droi, col, ordre) ' Quick sort
  ref = a((gauc + droi) \ 2, col)
  g = gauc: d = droi
  Do
    If ordre Then
       Do While a(g, col) < ref: g = g + 1: Loop
       Do While ref < a(d, col): d = d - 1: Loop
    Else
       Do While a(g, col) > ref: g = g + 1: Loop
       Do While ref > a(d, col): d = d - 1: Loop
    End If
    If g <= d Then
       For i = LBound(a, 2) To UBound(a, 2)
         temp = a(g, i): a(g, i) = a(d, i): a(d, i) = temp
       Next i
       g = g + 1: d = d - 1
    End If
  Loop While g <= d
  If g < droi Then QuickOrdre a, g, droi, col, ordre
  If gauc < d Then QuickOrdre a, gauc, d, col, ordre
End Sub