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

'dans le pire des cas soit  a l'envers carrément  elle met 20 tours 
Sub testMonoBoucle1()
    ReDim t(1 To 5)
    t(1) = "zaza"
    t(2) = "titi"
    t(3) = "loulou"
    t(4) = "fanfan"
    t(5) = "coco"
    t = SortArrayB(t)
    MsgBox Join(t, vbCrLf)
End Sub

'dans le meilleur des cas donc dans l'ordre au départ  elle met 4  tours
Sub testMonoBoucle2()
    ReDim t(1 To 5)
    t(1) = "coco"
    t(2) = "fanfan"
    t(3) = "loulou"
    t(4) = "titi"
    t(5) = "zaza"
    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

Dim Q
Sub test()
    Dim F&, I&, T
    Q = 0
    T = Application.Transpose([A1:A13].Value)
    Randomize
    'on mélange les items
    For I = 1 To UBound(T): F = 1 + Int(Rnd * (UBound(T) - 1)): m = T(I): T(I) = T(F): T(F) = m: Next
    texte = "depart: " & Join(T, ",")

    d = SortArrayC(T, False)
    texte = texte & vbCrLf & "après tri: " & Join(d, ",") & vbCrLf
    texte = texte & Q & " tours de boucle" & vbCrLf & String(15, "*")
    Debug.Print texte
End Sub

Public Function SortArrayC(ByVal T, Optional Asc As Boolean = True)
    Dim I&, V, A&, B&
    For I = LBound(T) + 2 To UBound(T)
        Q = Q + 1
        A = I - Abs(Asc)       'index d'échange
        B = I - Abs(Not Asc)   'index d'échange
        If T(A) > T(B) Then
            V = T(A)
            T(A) = T(B)
            T(B) = V
            I = I - 2
            If I < LBound(T) Then I = LBound(T)
        End If
    Next
    SortArrayC = T
End Function

Dim dicoD As DranrebDictionary
Dim dicoP As Patrickdictionary
Sub test_dico_de_Dranreb()
    Dim k, it, Cel As Range
    Set dicoD = New DranrebDictionary
    For Each Cel In [A1:a10].Cells
        If Not dicoD.Exists("toto") Then dicoD.Add Cel.Text, Cel.Offset(, 1).Text    'le if not exist est obligatoire  sinon ca plante
    Next
    k = dicoD.keys
    it = dicoD.items

    MsgBox k(1) & "-->" & it(1) 'ne fonctionne pas
    MsgBox dicoD.keys("toto")   'ne fonctionne pas
    MsgBox dicoD.keys(k(1))     'ne fonctionne pas
End Sub

Sub test_dico_de_patrick()
    Dim k, it, Cel As Range
    Set dicoP = New Patrickdictionary
    dicoP.Overwrite_Item = True    'permet d'imiter  le remplissage d'un vrai dico sans "Add"
    For Each Cel In [A1:a10].Cells
        dicoP.Add Cel.Text, Cel.Offset(, 1).Text
    Next
    k = dicoP.keys
    it = dicoP.items
    'mon dico est en base 1
    MsgBox k(1) & "-->" & it(1)
    MsgBox dicoP.keys("toto")
    MsgBox dicoP.keys(k(1))
End Sub


Sub testvraidico()
'comme on peut le voir avec cette méthode on a le overwrite de l'item
    Dim VraiDico As Object, k, it, Cel As Range
    Set VraiDico = CreateObject("Scripting.Dictionary")
    For Each Cel In [A1:a10].Cells
        VraiDico(Cel.Text) = Cel.Offset(, 1).Text
    Next
    k = VraiDico.keys
    it = VraiDico.items

    'le vrai dico est en base 0
    MsgBox k(0) & "-->" & it(0)
    MsgBox VraiDico("toto")
   MsgBox VraiDico(k(0))
   End Sub

Dim dicoD As DranrebDictionary
Sub test_dico_de_Dranreb()
    Dim k, it, Cel As Range
    Set dicoD = New DranrebDictionary
    For Each Cel In [A1:a10].Cells
        If Not dicoD.Exists(Cel.Text) Then dicoD.Add Cel.Text, Cel.Offset(, 1).Text    'le if not exist est obligatoire  sinon ca plante
    Next
    k = dicoD.Keys
    it = dicoD.Items

    MsgBox k(1) & "-->" & it(1) 'ca y est ça fonctionne
    'MsgBox dicoD.Keys("toto")   'ne fonctionne pas
    'MsgBox dicoD.Keys(CStr(k(0)))     'ne fonctionne pas
End Sub