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

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

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

Option Explicit
Public Value As Variant

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

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

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