Tri et Dictionnary
Bonjour,
Entre 2 agapes festives
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!
Merci pour ces précisions.
A+