Tri et Dictionnary

Bonjour,

Entre 2 agapes festives je manque un peu de lucidité pour résoudre ce petit entrainement sur base de Tri et de Dictionnary.

On travaille sur des Strings, pas dans la dentelle hein ! Pas de Range non plus : Tout doit se passer en VBA...

On a un string de référence :

SRef = "GALOPIN" par exemple (Ce string n'a aucune importance dans la procédure, il n'intervient ici que pour la présentation de la problématique.)

Si on compare ce string à un autre "HEURTER" par exemple on voit qu'ils n'ont aucun caractère commun.

On souhaite donc constituer un string trié dans l'ordre alphabétique avec les lettres "uniques" de "HEURTER" :

Le résultat de la fonction sera "EHRTU"

On peut donc résumer le code de la manière suivante :

Sub Test()
Dim STest$
STest = "HEURTER"
MsgBox Exclusions(STest) ' "EHRTU" !
End Sub

Function Exclusions$(STest$)
'...
Exclusions = ????
End Function

Ma problématique est de charger un Dictionnary avec les éléments de STest puis de trier le Dictionnary pour en refaire un string ordonné.

Précisions : Il s'agit d'une présentation simplifiée. Dans la réalité le Dictionnary est utilisé pour constituer une liste triée sans doublons avec un String concaténé du genre :

SNew =  "HKQWXZ" & "HEURTER"

Ainsi par voie d'essais successifs on obtiendra la liste triés des caractères de l'alphabet non présents dans le String de référence.

J'ai bien une solution un peu capillo-tractée mais elle oblige à passer par des Range (façon jb) qui ne sont pas vraiment souhaités.

Y a t-il quelqu'un d'assez lucide dans cette docte assemblée pour résoudre ce petit défi ?

A+

Bonjour Galopin,

non, je ne sais pas si je suis assez lucide ... mais si je me cantonne au titre, voici ce que j'utilise pour trier un dictionnaire

je pars ici d'une range

Sub listes()
Dim Data, dico As Object

    Data = Range("la_plage")
    Set dico = CreateObject("Scripting.Dictionary")

    ' mémorisation des valeurs sous forme de dictionnaire
    For i = 2 To UBound(Data)
        dico(Data(i, 1)) = ""
    Next

    ' transfert dans un tableau des clés pour tri
    Tbl = dico.keys
    QuickSort Tbl

    ' rechargement du dictionnaire avec clés triées et application des valeurs
    dico.RemoveAll
    For i = LBound(Tbl) To UBound(Tbl)
        dico(Tbl(i)) = 1
    Next i

    ' lecture des clés et valeurs
    For Each Cle In dico.keys
        Debug.Print Cle
    Next

End Sub

Public Sub QuickSort(vArray As Variant, _
  Optional ByVal inLow As Long = -1, _
  Optional ByVal inHi As Long = -1)
  Dim pivot   As Variant
  Dim tmpSwap As Variant
  Dim tmpLow  As Long
  Dim tmpHi   As Long
  inLow = IIf(inLow = -1, LBound(vArray), inLow)
  inHi = IIf(inHi = -1, UBound(vArray), inHi)
  tmpLow = inLow
  tmpHi = inHi
  pivot = vArray((inLow + inHi) \ 2)
  While (tmpLow <= tmpHi)
     While (vArray(tmpLow) < pivot And tmpLow < inHi)
        tmpLow = tmpLow + 1
     Wend
     While (pivot < vArray(tmpHi) And tmpHi > inLow)
        tmpHi = tmpHi - 1
     Wend
     If (tmpLow <= tmpHi) Then
        tmpSwap = vArray(tmpLow)
        vArray(tmpLow) = vArray(tmpHi)
        vArray(tmpHi) = tmpSwap
        tmpLow = tmpLow + 1
        tmpHi = tmpHi - 1
     End If
  Wend
  If (inLow < tmpHi) Then QuickSort vArray, inLow, tmpHi
  If (tmpLow < inHi) Then QuickSort vArray, tmpLow, inHi
End Sub

Reste à mettre le string dans le tableau d'origine !

petit bout d'essai

Function caracteres(cel As Range)
Dim dico As Object

    Set dico = CreateObject("Scripting.Dictionary")

    ' mémorisation des valeurs sous forme de dictionnaire
    For i = 1 To Len(cel.Value)
        dico(Mid(cel.Value, i, 1)) = ""
    Next

    ' transfert dans un tableau des clés pour tri
    Tbl = dico.keys
    QuickSort Tbl

    ' rechargement du dictionnaire avec clés triées et application des valeurs
    dico.RemoveAll
    For i = LBound(Tbl) To UBound(Tbl)
        dico(Tbl(i)) = 1
    Next i

    ' lecture des clés et valeurs
    caracteres = ""
    For Each Cle In dico.keys
        caracteres = caracteres & Cle
    Next

End Function

Public Sub QuickSort(vArray As Variant, _
  Optional ByVal inLow As Long = -1, _
  Optional ByVal inHi As Long = -1)
  Dim pivot   As Variant
  Dim tmpSwap As Variant
  Dim tmpLow  As Long
  Dim tmpHi   As Long
  inLow = IIf(inLow = -1, LBound(vArray), inLow)
  inHi = IIf(inHi = -1, UBound(vArray), inHi)
  tmpLow = inLow
  tmpHi = inHi
  pivot = vArray((inLow + inHi) \ 2)
  While (tmpLow <= tmpHi)
     While (vArray(tmpLow) < pivot And tmpLow < inHi)
        tmpLow = tmpLow + 1
     Wend
     While (pivot < vArray(tmpHi) And tmpHi > inLow)
        tmpHi = tmpHi - 1
     Wend
     If (tmpLow <= tmpHi) Then
        tmpSwap = vArray(tmpLow)
        vArray(tmpLow) = vArray(tmpHi)
        vArray(tmpHi) = tmpSwap
        tmpLow = tmpLow + 1
        tmpHi = tmpHi - 1
     End If
  Wend
  If (inLow < tmpHi) Then QuickSort vArray, inLow, tmpHi
  If (tmpLow < inHi) Then QuickSort vArray, tmpLow, inHi
End Sub

Bonsoir Steelson,

Oui j'en étais arrivé à une solution très proche de ta 2ème proposition sur la base des modèles de jb.

Il me reste à affiner les déclarations...

Voici ma solution finale :

Sub Test()
Dim S$
S = "HKQWXZ" & "HEURTER"
   MsgBox Exclusions(S)
End Sub
Function Exclusions(SNew$)
Dim i, b(), c, Arr(), res$
  Set Dico = CreateObject("Scripting.Dictionary")
  For i = 1 To Len(SNew)
    Dico(Mid(SNew, i, 1)) = ""
  Next
  ReDim b(1 To Len(SNew))
  i = 1
  For Each c In Dico.keys
     b(i) = c
     i = i + 1
  Next
  Call tri(b, 1, Dico.Count)
  Arr = Application.Transpose(b)
     For i = 1 To UBound(Arr)
      res = res & Arr(i, 1)
   Next
  Exclusions = res
End Function
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

Merci bonne soirée et bonne fin d'année.

A+

bonjour,

Enum ConstAdo
    adChar = 129
    adBSTR = 8
    adBoolean = 11
    adInteger = 3
    adUnsignedTinyInt = 17
    adDate = 7
    adDouble = 5
    adSingle = 4
End Enum
Sub test_A1()
    Dim rs As Object, I As Integer
    Set rs = CreateObject("adodb.Recordset")
    rs.Fields.Append "ID", adInteger, 8
    rs.Fields.Append "toto", adChar, 50
    rs.Open
    rs.Filter = "toto= 'ZZZ'"
    If rs.EOF Then
        I = I + 1
        rs.AddNew
        rs("ID") = I
        rs("toto") = "ZZZ"
        rs.Update
    End If
     rs.Filter = "toto= 'AAA'"
    If rs.EOF Then
        I = I + 1
        rs.AddNew
        rs("ID") = I
        rs("toto") = "AAA"
        rs.Update
    End If
     rs.Filter = ""
    ' rs.Sort = "toto desc" 'Z -> A
      rs.Sort = "toto"     ' A -> Z
    'rs.Sort = ""          'pas de trie
     ActiveCell.CopyFromRecordset rs
     rs.close
     set rs=Nothing
End Sub

Bonjour à tous,

avec une collection array et sa méthode .Sort :

Sub Test()
    Dim STest$
    STest = "HEURTER"
    MsgBox Exclusions(STest) ' "EHRTU" !
End Sub

Function Exclusions$(STest$)
    Dim arrList As Object, item, i As Long
    Set arrList = CreateObject("System.Collections.ArrayList") 'Create the ArrayList
    For i = 1 To Len(STest)
        If Not arrList.contains(Mid(STest, i, 1)) Then arrList.Add Mid(STest, i, 1)
    Next i
    arrList.Sort
    For Each item In arrList
        Exclusions = Exclusions & item
    Next item
End Function

S'il y a une grosse masse de données, contrôler si le temps d'exécution est correct... Aucune idée de la performance comparée à un tri de tableau vu que l'alimentation prends plus de temps.
eric

Enum ConAdo
    adChar = 129
    adBSTR = 8
    adBoolean = 11
    adInteger = 3
    adUnsignedTinyInt = 17
    adDate = 7
    adDouble = 5
    adSingle = 4
End Enum

Sub Test()
Dim S$
S = "HKQWXZ" & "HEURTER"
  MsgBox Exclusions(S)
End Sub
Function Exclusions(SNew$)
Dim rs As Object, i As Integer: Set rs = CreateObject("adodb.Recordset")
       rs.Fields.Append "Order", adChar, 1
       rs.Open
        For i = 1 To Len(SNew)
            rs.Filter = "Order= '" & Mid(SNew, i, 1) & "'"
            If rs.EOF Then
                rs.AddNew
                rs("Order") = Mid(SNew, i, 1)
                rs.Update
            End If
        Next
         rs.Filter = ""
         rs.Sort = "Order"
         Exclusions = Replace(rs.getString, Chr(13), "")

End Function

bonjour,

Sur le plan de la durée d'exécution, la différence est imperceptible.

Sur le plan cognitif la méthode d'Eriic est super, la méthode ADODB étant quasi incompréhensible à mon niveau.

Je comprend que dans la situation seul :

adChar = 129 'est indispensable

J'ai même tenté 90 au lieu de 129 qui m'interrogeait un peu....

Mais je pense que la question restera dans le marécage de mes insuffisances !

Bel effort sur ce sujet résolu : Chapeau bas Messieurs !

Meilleurs vœux également.

A+

Bonjour,

adChar est une constante d'ADODB!

ici on déclare un nouveau champ de type caractère avec une longueur de 1

adChar,1 =String(1)!

adchar est plus lisible que 129!

129 est une constante qui veut dire caractère.

si tu la replace par 7 ça veut dire que le champ est une date !

dans un exemple précédent j'avais mis ID integer

rs.Fields.Append "Order", adChar, 1

ADODB est utilisé dans les bases de données !

Recordset est une collection d'enregistrement !

je le manipule comme un dictionnarry sauf qu'il détient intrasecment une méthode de Tri !

Enum ConAdo? C'est un enumerateur de constante numérique.

un fois que tu a compris le système tu peux l'utiliser à loisir il n'y a plus grand chose à comprendre !

si j'avais déclaré AdoDb dans les références je n'aurais pas créé un enumerateur de constantes Ado mais comme j'utilise creatobject elle n'existe pas!

Bonjour,

galopin01 a écrit :

Mais je pense que la question restera dans le marécage de mes insuffisances !

tu ne seras pas le seul, chapeau dysorthographie ...

Merci pour ces précisions.

A+