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

[Magic_Doctor]

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.

 

[patricktoulon]

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 )

 

[patricktoulon]

re
tenez si ça intéresse

 

[laurent950]

Merci @patricktoulon

Un véritable intérêt jolie travail, encore merci @patricktoulon

tenez si ça intéresse

Laurent

 

[patricktoulon]

si vous voulez j'ajoute quelqyes demo utile dedans

 

[job75]

Bonsoir à tous,

Il me semble que ce fichier et cette fonction VBA répondent au problème posé au post #1 :

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.

 

[patricktoulon]

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

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

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

et maintenant utilisation en formule matricielle

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

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

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]

Bonjour à tous,

Avec un vecteur ligne on utilisera ce fichier (2) et cette fonction :

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+

 

[patricktoulon]

re
@job75 Attention a la limite de transpose

 

[job75]

re
@job75 Attention a la limite de transpose

On est sur une feuille donc le maximum de colonnes est 16384, bien inférieur à la limite de Transpose.

 

[patricktoulon]

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

 

[patricktoulon]

re
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

 

[job75]

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) :

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

 

[Magic_Doctor]

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]

Bonsoir à tous,

Il me semble que ce fichier et cette fonction VBA répondent au problème posé au post #1 :

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 :

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

 

[job75]

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 :

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