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
    If g <=...

Magic_Doctor

XLDnaute Barbatruc
Re,

En regardant attentivement, je viens de me rendre compte que, malheureusement, la solution de dysorthographie, ainsi que la tienne plantent dans certains cas. Tant que les voyelles ne sont pas diacritées, toutes les 2 fonctionnent. Mais dans le cas contraire, le tri est assez "folklorique". J'avais choisi des couleurs comme exemple (erreur de ma part), mais dans mon application il s'agit de noms de langues. Il est vrai que VBA a été conçu par des Anglo-Saxons dont la langue est une des rarissimes n'ayant aucun diacritique. D'où ces difficultés pour les gérer en VBA...
Si, dans ta macro, tu écris :
VB:
a = Array("jaune", "vert", "Guaraní", "Géorgien", "rouge", "noir", "fuchsia", "marron") 'tableau à une dimension, à adapter
Dans le ComboBox, "Guaraní" précède "Géorgien".
¡Caramba!

Quant à la fusion des matrices, j'y suis contraint en raison de la fonction qui sature au-delà d'un certain nombre d'items.
 
Dernière édition:

job75

XLDnaute Barbatruc
Eh oui les comparaisons alphabétiques en VBA se font en comparant les codes Ascii.

Comme CODE("u")=117 et CODE("é")=233 VBA considère que "u"<"é".

Ce n'est pas le cas dans une feuille de calcul, ="u"<"é" renvoie FAUX.

En effectuant le tri dans la feuille il n'y aura pas de problème
 

job75

XLDnaute Barbatruc
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
    If g <= d Then
      temp = a(g): a(g) = a(d): a(d) = temp
      temp = b(g): b(g) = b(d): b(d) = temp
      g = g + 1: d = d - 1
    End If
Loop While g <= d
If g < droi Then Call tri(a, b, g, droi)
If gauc < d Then Call tri(a, b, gauc, d)
End Sub
 

Pièces jointes

  • ComboBox(2).xlsm
    21.9 KB · Affichages: 14

Magic_Doctor

XLDnaute Barbatruc
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
    If g <= d Then
      temp = a(g): a(g) = a(d): a(d) = temp
      temp = b(g): b(g) = b(d): b(d) = temp
      g = g + 1: d = d - 1
    End If
Loop While g <= d
If g < droi Then Call tri(a, b, g, droi)
If gauc < d Then Call tri(a, b, gauc, d)
End Sub
Re,

Fichtre ! Là ça me dépasse, mais ça marche.
Merci pour ton aide.

¡Y sigue la revolución intelectual!
 

patricktoulon

XLDnaute Barbatruc
re
bonjour a tous
@job75
ma question plus haut était
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
pour être exacte, connais tu un moyen plus simple pour faire ce que fait cette fonction
VB:
Sub testy1()
    Dim Liste As Variant
    Liste = Array(1, 2, 3, 4, 5, 6, 7, 8, 9)
    MsgBox WhatIsIt(Liste)
End Sub

Sub testy3()
    Dim Liste As Variant
    Set Liste = [A1:A13]
    MsgBox WhatIsIt(Liste)
End Sub

Sub testy4()
    Dim Liste As Variant
    Set Liste = [A1:H1]
    MsgBox WhatIsIt(Liste)
End Sub

Sub testy5()
    Dim Liste As Variant
     Liste = "1,2,3,4,5,6,7,8,9"
    MsgBox WhatIsIt(Liste)
End Sub

Sub testy6()
    Dim Liste As Variant
     Liste = 12.36
    MsgBox WhatIsIt(Liste)
End Sub

Function WhatIsIt(ByVal a As Variant)
    If TypeName(a) = "Range" Then a = a.Value
    If TypeName(a) <> "Variant()" Then WhatIsIt = TypeName(a): Exit Function
    On Error Resume Next: X = UBound(a, 2)
    If Err.Number > 0 Then
        WhatIsIt = "array 1 dim"
        Err.Clear
    Else
        If UBound(a) > 1 Then WhatIsIt = "array 2 dim (colonne)"
        If UBound(a, 2) > 1 Then WhatIsIt = "array 2 dim (ligne )"
    End If
End Function
 
Bonjour le fil, le forum

pour être exacte, connais tu un moyen plus simple pour faire ce que fait cette fonction
Salut Patrick , un truc comme ça ?

Bien cordialement, @+
VB:
Function WhatIsIt(ByVal a As Variant)
    If IsArray(a) Then
        If TypeName(a) = "Range" Then WhatIsIt = "Array 2 dimensions, Colonnes : " & a.Columns.Count & " ,Lignes : " & a.Rows.Count Else WhatIsIt = "array 1 dimension (colonne) de " & Application.CountA(a) & " valeurs."
    Else
        If TypeName(a) = "Range" Then a = a.Value
        If TypeName(a) <> "Variant()" Then WhatIsIt = TypeName(a)
    End If
End Function
 
re,

petite modification pour gérer aussi les tableaux VB

Bien cordialement, @+
VB:
Sub testy2()
    Dim Liste(1 To 50, 1 To 10) As Variant
    MsgBox WhatIsIt(Liste)
End Sub

Function WhatIsIt(ByVal a As Variant)
    If IsArray(a) Then
        If TypeName(a) = "Range" Then
             a = a.Value
             WhatIsIt = "Array 2 dimensions, Colonnes : " & UBound(a, 2) + 1 - LBound(a, 2) & " ,Lignes : " & UBound(a, 1) + 1 - LBound(a, 1)
        Else
            If UBound(a) + 1 - LBound(a) = Application.CountA(a) Then WhatIsIt = "array 1 dimension (colonne) de " & Application.CountA(a) & " valeurs." _
                Else WhatIsIt = "Array 2 dimensions, Colonnes : " & UBound(a, 2) + 1 - LBound(a, 2) & " ,Lignes : " & UBound(a, 1) + 1 - LBound(a, 1)
        End If
    Else
        If TypeName(a) = "Range" Then a = a.Value
        If TypeName(a) <> "Variant()" Then WhatIsIt = TypeName(a)
    End If

une deuxième version plus light et plus juste d'après moi pour les tableaux Vb à une seule colonne traités comme un simple array.
VB:
Function WhatIsIt(ByVal a As Variant)
    If TypeName(a) = "Range" Then a = a.Value
    If IsArray(a) Then
        If UBound(a) + 1 - LBound(a) = Application.CountA(a) Then WhatIsIt = "array 1 dimension (colonne) de " & Application.CountA(a) & " valeurs." _
                Else WhatIsIt = "Array 2 dimensions, Colonnes : " & UBound(a, 2) + 1 - LBound(a, 2) & " ,Lignes : " & UBound(a, 1) + 1 - LBound(a, 1)
    Else
        If TypeName(a) <> "Variant()" Then WhatIsIt = TypeName(a)
    End If
End Function
 
Dernière édition:

mapomme

XLDnaute Barbatruc
Supporter XLD
Bonjour à tous,

Une autre version (renvoie 0 si ce n'est pas un tableau sinon renvoie la dimension) :
VB:
Function Dimension&(x)
Dim max&, G
      On Error GoTo FIN:
      Do: max = max + 1: G = Empty: G = UBound(x, max): Loop Until IsEmpty(G)
FIN:  Dimension = max - 1
End Function
 

Pièces jointes

  • Dimension array- v1.xlsm
    19.4 KB · Affichages: 5

laurent950

XLDnaute Accro
Bonjour @patricktoulon

J'avais vu cela pour les tests sur tableau 1 dimension et 2 dimensions, puis @Dranreb ma aussi aidée (un grand merci à @Dranreb)

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

En Poste #24 il y a la solution et @Dranreb à complété en Poste #25 (C'est assez complet)
 

patricktoulon

XLDnaute Barbatruc
re
merci a tous
je regarde ça tout de suite
mais je crois que vous m'avez donné l'astuce pour me passer de "on error..."
je teste tout ça et reviens

Bonjour @laurent950
il faut bien comprendre que ma démarche est de simplifier ;) pas de savoir faire

edit :

@Yeahou: ben non en fait l'astuce n'est pas valable dans tout les sens
sur les tablo 2 dim en base 0 c'est pas bon

'astuce de Yeahou
VB:
'Astuce
'MsgBox UBound(a) + 1 - LBound(a) = Application.CountA(a)

'mise en exercice
 
Sub testy7()
a = [A1:H1].Value
MsgBox oneDim(a)
End Sub
Sub testy8()
a = Array(1, 2, 3, 4, 5, 6, 7, 8, 9)
MsgBox oneDim(a)
End Sub
Sub testy9()
Dim a(0 To 5, 1)
  a(5, 0) = "toto "
MsgBox oneDim(a) & " " & UBound(a, 2)
End Sub
Sub testy10() ' erreur donne vrai quand base 0
Dim a(0 To 5, 0)
  a(5, 0) = "toto "
MsgBox oneDim(a) & " " & UBound(a, 2)
End Sub

Function oneDim(a)
  oneDim = UBound(a) + 1 - LBound(a) = Application.CountA(a)
End Function


@mapomme :il me faut non seulement le (1/2 dim) mais aussi le sens (ligne ou colonne)
et le stack d'erreur est dégressif( en terme de mémoire ) jusqu'a fin de macro en VBA
autrement dit quand tu gere une erreur tu prend de la mémoire et même si tu clear l'erreur le stack contient toujours son l'emplacement et cette mémoire utilisé n'est donc plus dispo pour le reste
d'autant plus que tu ne clôture pas la gestion dans ton exemple
je sais c'est pinailler mais bon 🤣 🤣

quand je pose une question c'est jamais si simple vous devriez le savoir maintenant 🤣🤣🤣🤣

mais je crois que je vais ouvrir un post a ce sujet car je crois que ça ne va pas être aussi simple
 
Dernière édition:

mapomme

XLDnaute Barbatruc
Supporter XLD
d'autant plus que tu ne clôture pas la gestion dans ton exemple
Comme je disais dans un autre message sur une remarque justifiée de ta part ;), la flemme toujours la flemme :confused:.

Dis moi donc, quand as-tu eu un bogue de saturation mémoire dû à la gestion d'exception? :cool:

Quand au sens, un tableau n'en a pas. Il n'a que des dimensions. Si tu as 4 dimensions, tu gères les éléments en fonction de leur coordonnées dans le tableau. Il n'y a pas de ligne, colonne, hauteur ou autre, non ? C'est notre petit cerveau (du moins pour moi) qui a besoin de se raccrocher à la notion de ligne et colonne.

Allez! On va commencer à éplucher les légumes 🥕🥕. Bon appétit à tous 🍷
 
Dernière édition:

laurent950

XLDnaute Accro
Bonjour

Comment renvoyer le nombre de dimensions d’une variable (Variant) qui lui est passée dans VBA sans gestion d'erreur.


avec l'astuce de
@Yeahou: ben non en fait l'astuce n'est pas valable dans tout les sens
sur les tablo 2 dim en base 0 c'est pas bon

'astuce de Yeahou
Sub testy7()
a = [A1:H1].Value
MsgBox oneDim(a)
End Sub
'
Sub testy8()
a = Array(1, 2, 3, 4, 5, 6, 7, 8, 9)
MsgBox oneDim(a)
End Sub
'
Sub testy9()
Dim a(0 To 5, 1)
a(5, 0) = "toto "
MsgBox oneDim(a) & " " & UBound(a, 2)
End Sub
'
Sub testy10() ' erreur donne vrai quand base 0
Dim a(0 To 5, 0)
a(5, 0) = "toto "
MsgBox oneDim(a) & " " & UBound(a, 2)
End Sub

A tester avec ce code :
Repérage des Dimensions des Variables tableaux sans la gestion des erreurs

l'astuce de @Yeahou c'est a = [A1:H1].Value (ajouté qui fonctionne avec le code ci-dessous)

Solution en Poste #14 de cette aide : https://stackoverflow.com/questions...sions-of-a-variant-variable-passed-to-it-in-v

VB:
#If VBA7 Then
  Private Type Pointer: Value As LongPtr: End Type
  Private Declare PtrSafe Sub RtlMoveMemory Lib "kernel32" (ByRef dest As Any, ByRef src As Any, ByVal Size As LongPtr)
#Else
  Private Type Pointer: Value As Long: End Type
  Private Declare Sub RtlMoveMemory Lib "kernel32.dll" (ByRef dest As Any, ByRef src As Any, ByVal Size As Long)
#End If

Private Type TtagVARIANT
    vt As Integer
    r1 As Integer
    r2 As Integer
    r3 As Integer
    sa As Pointer
End Type

Public Function GetDims(source As Variant) As Integer
    Dim va As TtagVARIANT
    RtlMoveMemory va, source, LenB(va)                                            ' read tagVARIANT              '
    If va.vt And &H2000 Then Else Exit Function                                   ' exit if not an array         '
    If va.vt And &H4000 Then RtlMoveMemory va.sa, ByVal va.sa.Value, LenB(va.sa)  ' read by reference            '
    If va.sa.Value Then RtlMoveMemory GetDims, ByVal va.sa.Value, 2               ' read cDims from tagSAFEARRAY '
End Function
 
Dernière édition:

Discussions similaires

Statistiques des forums

Discussions
311 711
Messages
2 081 796
Membres
101 817
dernier inscrit
carvajal