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

[patricktoulon]

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

 

[patricktoulon]

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

 

[RyuAutodidacte]

non non je ne flancherai pas avant d'avoir fini

 

[patricktoulon]

c'est quoi ta base
1 collectionou 2?
1 dictionnaire

 

[RyuAutodidacte]

c'est quoi ta base
1 collectionou 2?
1 dictionnaire

1 collection
Edit : faut bien que ca soit Mac PC

 

[dysorthographie]

Module1

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

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

Option Explicit
Public Value As Variant

 

[patricktoulon]

re
travailler tout en string comme ca c'est lourd très lourd

 

[patricktoulon]

ryu
sans collection c'est encore plus Mac /pc

 

[dysorthographie]

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]

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 !

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]

Le dictionnaire n'accepte pas les doublons.
Ja cru comprendre que tu voulais faire un dictionary pour Mac !

 

[patricktoulon]

re
Ok j'ai pigé a peu près ta sub sort mono boucle
reste a l'adapter pour array base 1 et 0

Le dictionnaire n'accepte pas les doublons.
Ja cru comprendre que tu voulais faire un dictionary pour Mac !

ben oui mais je quand même pouvoir faire un reverse

 

[dysorthographie]

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]

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

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 !

 

[patricktoulon]

parfois ça a l'air mais ça n'a pas la chanson
je te laisse juger par toi même

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

 

[dysorthographie]

Bonjour Patrick et bonjour le forum.

C'est ce que toi et Marc M m'aviez fait remarqué quand je l'avais proposer sur DVP.COM .

Ca ne me pose pas de problème je l'aime bien