Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

XL 2013 les machistes (utilisateurs de Mac OS peuvent ils tester ceci

patricktoulon

XLDnaute Barbatruc
Bonjour à tous
@RyuAutodidacte m' a rappelé un lien vers un amis de l'autre monde concernant une classe pseudo dictionnaire pour MAC
malgré que j'apprécie beaucoup l'auteur (avec qui j'ai même collaboré sur l’accélérateur de requête entre autres ) ,je trouve que c'est un peu usine à gaz

j'ai donc fait les choses à ma façon
mais avant d'aller plus loin car des idées j'en ai plein ,si vous êtes un utilisateur sur MAC pouvez vous tester ce pseudo dictionnaire
sur Windows ça match il me faut confirmation sur MAC

Merci pour vos retours
 

Pièces jointes

  • classe dictionary pour Mac.xlsm
    18.3 KB · Affichages: 10
Dernière édition:

patricktoulon

XLDnaute Barbatruc
re
ben tu es déjà influencé
avec le dictionnaire ça n'a pas d’intérêt on peu le faire direct dans la sub le overwrite ou cumulate
d'ailleurs le cumulate est déjà automatiquement dans les deux précédentes versions 2 collect ou une collect
 

dysorthographie

XLDnaute Accro
Module1
VB:
Sub test()
Dim Dico As New Dictionary
Dico.Intem("A") = 1

Range("A2") = "A"
Dico.Add Range("A2"), "Z"
 Dico.Intem("A") = Dico.Intem("A") + 1
Dico.Intem("A") = Dico.Intem("A") + 1
Debug.Print Dico.Intem("A")
Dico.Remove "A"
Debug.Print Dico.Intem(1), Dico.Intem(1).Address
Dico.Add "AAAAA", "A"
Dico.Add "BBBB", "V"
Dico.Add "HHHH", "T"
Dico.Add "RRRRR", "B"
Dico.Sort

Set ss = Dico.Intems
K = Dico.Keys
For Each v In K
    Debug.Print ss(v).Value
Next
Dico.Add "toto", "A"

End Sub
Classe Dictionary
Code:
Private K As String, Dico As New Collection, Ks() As String
Function Exist(Key As String) As Boolean
Exist = InStr("©" & K & "©", "©" & Key & "©")
End Function
Property Get Intem(ByVal Key As String) As Variant
If Not Exist(Key) Then
    If IsNumeric(Key) Then
    Dim Ks() As String: Ks = Split(K, "©")
        If UBound(Ks) < Val(Key) Then Dico.Add New ClasseValue, Key: K = K & "©" & Key Else Key = Ks(Val(Key))
    Else
        Dico.Add New ClasseValue, Key: K = K & "©" & Key
    End If
End If

If IsObject(Dico(Key).Value) Then
   Set Intem = Dico(Key).Value
Else
    Intem = Dico(Key).Value
End If
End Property
Property Let Intem(ByVal Key As String, Value As Variant)
If Not Exist(Key) Then
    If IsNumeric(Key) Then
    Dim Ks() As String: Ks = Split(K, "©")
        If UBound(Ks) < Val(Key) Then Dico.Add New ClasseValue, Key: K = K & "©" & Key Else Key = Ks(Val(Key))
    Else
        Dico.Add New ClasseValue, Key: K = K & "©" & Key
    End If
End If

If IsObject(Dico(Key).Value) Then
   Set Dico(Key).Value = Value
Else
     Dico(Key).Value = Value
End If
End Property
Property Get Intems() As Variant
  Dim T() As String, i As Integer, d As New Collection
  Ks() = Split(K, "©")
  For i = 1 To UBound(Ks)
    d.Add Dico(Ks(i)), Ks(i)
  Next
  Set Intems = d
End Property

Public Sub Add(Value As Variant, Key As Variant)
If Key = "" Then
    Dico.Add New ClasseValue
Else
    If Exist(CStr(Key)) Then Err.Raise 457, "Dictionary", "Cette clé est déjà associée à un élément de cette collection"
   Dico.Add New ClasseValue, CStr(Key)
   K = K & "©" & Key
End If

If IsObject(Value) Then
   Set Dico(CStr(Key)).Value = Value
Else
     Dico(CStr(Key)).Value = Value
End If

End Sub
Public Sub Remove(Key As String)
Dico.Remove Key
K = Replace(K & "©", "©" & Key & "©", "©")
If Right(K, 1) = "©" Then Mid(K, Len(K), 1) = " "
K = Trim(K)
End Sub
Public Sub Clear()
Set Dicoc = New Collection: K = ""
End Sub
Public Sub Sort(Optional Desc As Boolean = True)
Dim T() As String
T() = Split(K, "©")
For i = 2 To UBound(T)
    If T(i - Abs(Desc)) > T(i - Abs(Not Desc)) Then
        a = T(i - Abs(Desc))
       T(i - Abs(Desc)) = T(i - Abs(Not Desc))
        T(i - Abs(Not Desc)) = a
        i = i - 2
        If i < 1 Then i = 1
    End If
Next
K = Join(T, "©")
End Sub

Public Function Keys() As String()
Dim T() As String, Ks() As String, i As Integer
T() = Split(K, "©")
ReDim Ks(1 To UBound(T))
For i = LBound(Ks) To UBound(Ks)
    Ks(i) = T(i)
Next
Keys = Ks
End Function
classe ClasseValue
Code:
Option Explicit
Public Value As Variant
 

Pièces jointes

  • Dictionary.xlsm
    20.5 KB · Affichages: 0

dysorthographie

XLDnaute Accro
Tu refais en VBA le même code que fait une collection mais en assembleur.

Les collections fonctionnent sur MAc tu as le droit de t'en priver.

Si tu n'avais pas posté je ne me serais jamais penché sur le sujet, je suis Macophobe.

Ton idée du début de faire 2 collections une pour le Keys l'autre pour les items me paraissait une bonne idée !
 

patricktoulon

XLDnaute Barbatruc
non les deux collections c'est une mauvaise idée justement dans le sens ou je ne peux pas faire de reverse puisqu'une collection n'accepte pas les doublons je m'en suis rendu compte trop tard

une collection oui c'est (la version 2 et 3 )
Tu refais en VBA le même code que fait une collection mais en assembleur.
bien obligé pour Mac et si tu avais bien observé comme l'a très bien dit Laurent je fait ce que je peut faire avec une collection et un dictionnaire et même plus
en fait ma classe se rapproche plus des object sytem.arrayList et system..sortedList

pour être honnête Robert venant de toi le Add en string pour le re splitter plus tard c'est moyen
par contre ta fonction sort (mono boucle) est intéressante
 

dysorthographie

XLDnaute Accro
VB:
Dim T(2 To 6) As String
Public Sub Sort Optional Desc As Boolean = True)
For i = LBound(T) + 1 To UBound(T)
    If T(i - Abs(Desc)) > T(i - Abs(Not Desc)) Then
        a = T(i - Abs(Desc))
       T(i - Abs(Desc)) = T(i - Abs(Not Desc))
        T(i - Abs(Not Desc)) = a
        i = i - 2
        If i < LBound(T) Then i = LBound(T)
    End If
Next
End Sub
Sub test()
b = Array("Z", "Y", "X", "W", "V")
For i = 0 To 4
    T(i + 2) = b(i)
Next
Sort T
Sort T, False
End Sub
 

dysorthographie

XLDnaute Accro
j'avais commencé à 2 car je voulais passer le zéro à ""

VB:
Public Function SortArray(ByVal t, Optional Desc As Boolean = True)
For I = LBound(t) + 1 To UBound(t)
    If t(I - Abs(Desc)) > t(I - Abs(Not Desc)) Then
        A = t(I - Abs(Desc))
       t(I - Abs(Desc)) = t(I - Abs(Not Desc))
        t(I - Abs(Not Desc)) = A
        I = I - 2
        If I < LBound(t) Then I = LBound(t)
    End If
Next
SortArray = t
End Function
Sub test()
Dim t
ReDim t(2 To 6)
b = Array("Z", "Y", "X", "W", "V")
For I = 0 To 4
    t(I + 2) = b(I)
Next
 t = SortArray(t)
    MsgBox Join(t, vbCrLf)
End Sub
Sub testccc()
    ReDim t(1 To 5)
     t(1) = "zaza"
    t(2) = "loulou"
    t(3) = "fanfan"
    t(4) = "titi"
    t(5) = "coco"
   t = SortArray(t)
    MsgBox Join(t, vbCrLf)
End Sub

Sub testDDD()
    ReDim t$(4)
    t(0) = "zaza"
    t(1) = "loulou"
    t(2) = "fanfan"
    t(3) = "titi"
    t(4) = "coco"
    t = SortArray(t)
    MsgBox Join(t, vbCrLf)
End Sub

J'ai écrit Desc As Boolean = True mais c'est plutôt Asc !
 
Dernière édition:

patricktoulon

XLDnaute Barbatruc
parfois ça a l'air mais ça n'a pas la chanson
je te laisse juger par toi même
VB:
Sub testdoubleboucle()
    Dim X
    ReDim t(1 To 5)
    t(1) = "zaza"
    t(2) = "titi"
    t(3) = "loulou"
    t(4) = "fanfan"
    t(5) = "coco"
    X = SortArrayA(t, False)
    MsgBox Join(X, vbCrLf)
End Sub


Function SortArrayA(b, Optional AsC As Boolean = True)
    For i = LBound(b) To UBound(b) - 1
        For a = i + 1 To UBound(b)
            If AsC = True Then c = i: d = a Else c = a: d = i
            q = q + 1
            If b(c) > b(d) Then
                tp = b(c)
                b(c) = b(d)
                b(d) = tp
            End If
        Next
    Next
    MsgBox q & " tours de boucle"
    SortArrayA = b
End Function

Sub testMonoBoucle()
    ReDim t(1 To 5)
    t(1) = "zaza"
    t(2) = "loulou"
    t(3) = "fanfan"
    t(4) = "titi"
    t(5) = "coco"
    t = SortArrayB(t)
    MsgBox Join(t, vbCrLf)
End Sub
Public Function SortArrayB(ByVal t, Optional Desc As Boolean = True)
    For i = LBound(t) + 1 To UBound(t)
        q = q + 1
        If t(i - Abs(Desc)) > t(i - Abs(Not Desc)) Then
            a = t(i - Abs(Desc))
            t(i - Abs(Desc)) = t(i - Abs(Not Desc))
            t(i - Abs(Not Desc)) = a
            i = i - 2
            If i < LBound(t) Then i = LBound(t)
        End If
    Next
    MsgBox q & " tours de boucle"
    SortArrayB = t
End Function
 
Dernière édition:
Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…