XL 2010 Trier, en VBA, un Array par ordre alphabétique

Magic_Doctor

XLDnaute Barbatruc
Bonjour,

Je me heurte à un problème apparemment simple.
J'ai un Array :
Liste = Array("jaune", "vert", "orange", "blanc", "rouge", "noir", "fuchsia", "marron")

Comment le trier par odre alphabétique, afin d'obtenir :
Liste = Array("blanc", "fuchsia","jaune", "marron", "noir", "orange", "rouge", "vert")

Merci d'avance pour toute réponse.
 
Solution
Cela dit en VBA on s'en sort très bien en utilisant 2 tableaux a et b, fichier (2) :
VB:
Private Sub Combobox1_GotFocus()
Dim a, b, x%
a = Array("jaune", "vert", "guaraní", "georgien", "rouge", "noir", "fuchsia", "marron") 'tableau à une dimension sans accents et en minuscules, à adapter
b = Array("jaune", "vert", "Guaraní", "Géorgien", "rouge", "noir", "fuchsia", "marron") 'tableau à une dimension avec accents, à adapter
tri a, b, 0, UBound(a)
ComboBox1.List = b 'liste avec accents
ComboBox1.DropDown 'déroule la liste
End Sub

Sub tri(a, b, gauc, droi) ' Quick sort
Dim ref, g, d, temp
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...

patricktoulon

XLDnaute Barbatruc
re
de rien Laurent
oui et bizarrement plus rapide alors que je n'ai fait que déplacer des instructions
c'est peut être le fait que le min max etait dans une sub appelée ( je vois que ça)

Attention étant donné que j'ai ajouté un argument
tout les appels récursifs doivent l'avoir aussi OBLIGATOIREMENT!!!!
même si il est optionel et que pour le premier appel je peu m'en passer pour le "croissant"

avec ce conditionnement je serai curieux de le voir fonctionner en tant que fonction et donc d'utiliser un return (perso je préférerais )
 

job75

XLDnaute Barbatruc
Bonsoir à tous,

Il me semble que ce fichier et cette fonction VBA répondent au problème posé au post #1 :
VB:
Function ClasseColonne(r As Range)
'r est un vecteur colonne
Dim a
a = r
tri a, 1, UBound(a)
ClasseColonne = a 'vecteur colonne
End Function

Sub tri(a, gauc, droi) ' Quick sort
Dim ref, g, d, temp
ref = a((gauc + droi) \ 2, 1)
g = gauc: d = droi
Do
    Do While a(g, 1) < ref: g = g + 1: Loop
    Do While ref < a(d, 1): d = d - 1: Loop
    If g <= d Then
      temp = a(g, 1): a(g, 1) = a(d, 1): a(d, 1) = 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
Bonne nuit.
 

Pièces jointes

  • Classement(1).xlsm
    17 KB · Affichages: 5

patricktoulon

XLDnaute Barbatruc
Bonjour à tous
@job75
impec pour le deux dim (colonne)
comme je l'ai dit plus haut pour la version de @laurent950
  1. il serait intéressant d'en faire une fonction
  2. utilisable aussi en formule matricielle même si la fonction tri Excel existe elle requiert une manipulation
  3. de pouvoir choisir l'ordre croissant/décroissant
  4. de pouvoir lui injecter aussi bien un object range qu'un tableau variant 2 dim (x lignes ,1colonne)
  5. et de pouvoir aussi simplifier l'appel
voila chose faite
voici donc ta version en fonction (return) avec toutes ces options

VB:
Function ColumnOrder(a, Optional gauc = -1, Optional droi = -1, Optional sens As Long = 0)  ' Quick sort
    Dim ref, g&, d&, temp, X
    If TypeName(a) = "Range" Then a = a.Value
    droi = IIf(droi = -1, UBound(a), droi): gauc = IIf(gauc = -1, LBound(a), gauc)
    ref = a((gauc + droi) \ 2, 1)
    g = gauc: d = droi
    Do
        Select Case sens
        Case 0
            ' Pour un tri croissant
            Do While a(g, 1) < ref: g = g + 1: Loop
            Do While ref < a(d, 1): d = d - 1: Loop
        Case 1
            ' Pour un tri décroissant
            Do While a(g, 1) > ref: g = g + 1: Loop
            Do While ref > a(d, 1): d = d - 1: Loop
        End Select
        If g <= d Then
            temp = a(g, 1): a(g, 1) = a(d, 1): a(d, 1) = temp
            g = g + 1: d = d - 1
        End If
    Loop While g <= d
    If g < droi Then X = ColumnOrder(a, g, droi, sens)
    If gauc < d Then X = ColumnOrder(a, gauc, d, sens)
    ColumnOrder = a
End Function

exemple d'utilisation en vba
VB:
Sub testcolonne()
'on injecte le value du range
    Dim a
    a = [A1:A13].Value
    [B1:B13] = ColumnOrder(a)      ' pour ordre croissant plus d'arguments necessaires
    [C1:C13] = ColumnOrder(a, sens:=1)      'ordre décroissant uniquement l'argument "sens" au premier appel
End Sub
Sub testcolonne2()
'on injecte l'object range
    Dim a
    Set a = [A1:A13]
    [B1:B13] = ColumnOrder(a)      ' pour ordre croissant plus d'arguments necessaires
    [C1:C13] = ColumnOrder(a, sens:=1)      'ordre décroissant uniquement l'argument "sens" au premier appel
End Sub
résultat
1623401091863.png


et maintenant utilisation en formule matricielle
demo7.gif


voila réutilisable a souhait
-----------------------------------------------------------------------------------------------------------------
a l'attention de @laurent950 et pour les autres aussi bien sur
voici la sienne pour les array une dim en fonction avec les même options
VB:
Function OrderedArray(a, Optional gauc = -1, Optional droi = -1, Optional sens As Long = 0)  ' Quick sort
    Dim ref, g&, d&, temp, X
    droi = IIf(droi = -1, UBound(a), droi): gauc = IIf(gauc = -1, LBound(a), gauc)
    ref = a((gauc + droi) \ 2)
    g = gauc: d = droi
    Do
        Select Case sens    'choix du sens
        Case 0
            ' Pour un tri croissant
            Do While a(g) < ref: g = g + 1: Loop
            Do While ref < a(d): d = d - 1: Loop
        Case 1
            ' Pour un tri décroissant
            Do While a(g) > ref: g = g + 1: Loop
            Do While ref > a(d): d = d - 1: Loop
        End Select
        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 X = OrderedArray(a, g, droi, sens)
    If gauc < d Then X = OrderedArray(a, gauc, d, sens)
    OrderedArray = a
End Function
sub de test
VB:
Sub test()
    Dim Liste As Variant
    Liste = Array("jaune", "vert", "orange", "blanc", "rouge", "noir", "fuchsia", "marron")
    MsgBox Join(OrderedArray(Liste), " : ")'croissant
    MsgBox Join(OrderedArray(Liste, sens:=1), " : ")' décroissant
End Sub
;)
 

job75

XLDnaute Barbatruc
Bonjour à tous,

Avec un vecteur ligne on utilisera ce fichier (2) et cette fonction :
VB:
Function ClasseLigne(r As Range)
'r est un vecteur ligne
Dim a
a = Application.Transpose(Application.Transpose(r))
tri a, 1, UBound(a)
ClasseLigne = a 'vecteur ligne
End Function

Sub tri(a, gauc, droi) ' Quick sort
Dim ref, g, d, temp
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
A+
 

Pièces jointes

  • Classement(2).xlsm
    17.3 KB · Affichages: 4

patricktoulon

XLDnaute Barbatruc
re
a oui tu es resté sur un "Range" moi je fait les deux ("Range"/tableau(2dim))

je pense même que la version array 1 dim pourrait servir pour tout en modifiant la dimension avec index au départ et en la remettant comme l'original en fin de traitement
j'ai pas voulue ralentir le quick sort
 

job75

XLDnaute Barbatruc
par contre si tu connais une méthode pour tester un tableau (si 1 dim ou 2 dim )sans gestion d'erreur je suis preneur
Tu veux dire une fonction qui fonctionne dans les 2 cas, alors utilise ce fichier (3) :
VB:
Function Classe(r As Range)
'r est un vecteur ligne ou un vecteur colonne
If r.Count = 1 Then Classe = r: Exit Function
Dim a
If r.Columns.Count = 1 Then a = r Else a = Application.Transpose(r)
tri a, 1, UBound(a)
If r.Columns.Count = 1 Then Classe = a Else Classe = Application.Transpose(a) 'vecteur ligne ou vecteur colonne
End Function

Sub tri(a, gauc, droi) ' Quick sort
Dim ref, g, d, temp
ref = a((gauc + droi) \ 2, 1)
g = gauc: d = droi
Do
    Do While a(g, 1) < ref: g = g + 1: Loop
    Do While ref < a(d, 1): d = d - 1: Loop
    If g <= d Then
      temp = a(g, 1): a(g, 1) = a(d, 1): a(d, 1) = 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
 

Pièces jointes

  • Classement(3).xlsm
    17.9 KB · Affichages: 3

Magic_Doctor

XLDnaute Barbatruc
VB:
Sub testAvecArray()
    liste = Array("blanc", "marron", "fuchsia", "rouge", "jaune", "noir", "orange", "vert")
   
Debug.Print Join(simplyarrSort(liste), ";"), Join(simplyarrSort(liste, True), ";")
End Sub
Function simplyarrSort(tbl, Optional Decrm As Boolean = False)
    Dim I&
    For I = LBound(tbl) + 1 To UBound(tbl)
        If tbl(I + Decrm) < tbl(I + Not Decrm) Then
            temp = tbl(I + Not Decrm): tbl(I + Not Decrm) = tbl(I + Decrm):   tbl(I + Decrm) = temp
            I = I - 2
            If I < 0 Then I = 0
        End If
    Next
    simplyarrSort = tbl
End Function
Bonjour dysorthographie,

C'est exactement ce que je désirais. Je viens d'essayer ta fonction avec 250 items, ça marche très bien.
Merci pour ton aide.
 

Magic_Doctor

XLDnaute Barbatruc
Bonsoir à tous,

Il me semble que ce fichier et cette fonction VBA répondent au problème posé au post #1 :
VB:
Function ClasseColonne(r As Range)
'r est un vecteur colonne
Dim a
a = r
tri a, 1, UBound(a)
ClasseColonne = a 'vecteur colonne
End Function

Sub tri(a, gauc, droi) ' Quick sort
Dim ref, g, d, temp
ref = a((gauc + droi) \ 2, 1)
g = gauc: d = droi
Do
    Do While a(g, 1) < ref: g = g + 1: Loop
    Do While ref < a(d, 1): d = d - 1: Loop
    If g <= d Then
      temp = a(g, 1): a(g, 1) = a(d, 1): a(d, 1) = 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
Bonne nuit.
Bonjour job,

Cette liste triée n'est pas destinée à apparaître sur une feuille mais à alimenter un ComboBox. En d'autres termes, tout se passe dans la macro. Voilà pourquoi la solution de dysorthographie (post #11) a satisfait mes souhaits.
Je résume les problèmes auxquels j'ai eu à faire face.
Une fonction doit me renvoyer une liste de 250 items. Impossible, elle sature à partir d'exactement 184 items.
Pour contourner le problème, je réalise 2 fonctions qui ne contiendront chacune que 150 items (je me suis limité à 150 pour être tranquille).
J'ai trouvé sur le net une fonction qui permet de fusionner les items des 2 fonctions précédentes.
Ne restait plus qu'à trier par ordre alphabétique tous ces items qui viendront alimenter le ComboBox.
Finalement, la fonction qui gère l'ensemble de ces opérations est la suivante :
VB:
Function MergeAndSortArrays(arr1() As Variant, arr2() As Variant, Optional tri As Boolean = True, Optional Decrm As Boolean = False) As Variant
'**************************************************************************************************************************
'Fusionne 2 matrices de longueurs différentes et tri le contenu
'https://stackoverflow.com/questions/1588913/how-do-i-merge-two-arrays-in-vba (pour la fusion des Arrays)
'dysorthographie (pour le tri de l'Array résultant)

'- arr1 : 1ère matrice
'- arr2 : 2ème matrice
'- tri : si True (ou omis) --> tri des 2 matrices fusionnées
'        si False          --> pas de tri
'- Decrm : si False (ou omis) --> tri croissant
'          si True            --> tri décroissant
'Ex : arr1 = Array("jaune", "vert", "orange")  |  arr2 = Array("blanc", "rouge", "noir", "fuchsia", "marron")
'     MergeAndSortArrays(arr1, arr2, False)  --> "jaune", "vert", "orange", "blanc", "rouge", "noir", "fuchsia", "marron"
'     MergeAndSortArrays(arr1, arr2)         --> "blanc", "fuchsia", "jaune", "marron", "noir", "orange", "rouge", "vert"
'     MergeAndSortArrays(arr1, arr2, , True) --> "vert", "rouge", "orange", "noir", "marron", "jaune", "fuchsia", "blanc"
'**************************************************************************************************************************

Dim returnThis() As Variant, len1 As Integer, len2 As Integer, lenRe As Integer, counter As Integer
Dim i&, temp
  
    len1 = UBound(arr1)
    len2 = UBound(arr2)
    lenRe = len1 + len2
    ReDim returnThis(1 To lenRe)
    counter = 1

    'Fusion des 2 matrices
    Do While counter <= len1 'get first array in returnThis
        returnThis(counter) = arr1(counter)
        counter = counter + 1
    Loop
    Do While counter <= lenRe 'get the second array in returnThis
        returnThis(counter) = arr2(counter - len1)
        counter = counter + 1
    Loop

    'Tri de la matrice résultante
    If tri Then
        For i = LBound(returnThis) + 1 To UBound(returnThis)
            If returnThis(i + Decrm) < returnThis(i + Not Decrm) Then
                temp = returnThis(i + Not Decrm): returnThis(i + Not Decrm) = returnThis(i + Decrm): returnThis(i + Decrm) = temp
                i = i - 2
                If i < 0 Then i = 0
            End If
        Next
    End If
    MergeAndSortArrays = returnThis

End Function
 
Dernière édition:

job75

XLDnaute Barbatruc
Tout cela paraît bien compliqué Magic_Doctor.

Je pense que la macro bien connue Quick sort est la solution la plus rapide.

Et pour alimenter la ComboBox (installée ici sur la feuille de calcul) c'est très simple :
VB:
Private Sub Combobox1_GotFocus()
Dim a, x%
a = Array("jaune", "vert", "orange", "blanc", "rouge", "noir", "fuchsia", "marron") 'tableau à une dimension, à adapter
tri a, 0, UBound(a)
ComboBox1.List = a
ComboBox1.DropDown 'déroule la liste
End Sub

Sub tri(a, gauc, droi) ' Quick sort
Dim ref, g, d, temp
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
 

Pièces jointes

  • ComboBox(1).xlsm
    21.4 KB · Affichages: 3

Discussions similaires

Haut Bas