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

Public elements As New Collection
Public key
Public item


Public Function Add(k, Optional i As Variant = "")
    ind = Me.Exists(k)
    If ind = 0 Then
        Dim cl As New dictionnaire
        cl.key = k
        cl.item = i
        Me.elements.Add cl
    Else
        Me.elements(ind).item = i
    End If
End Function
Public Function Exists(k) As Long
    For Each elem In Me.elements
        i = i + 1: If elem.key = k Then Exists = i: Exit For
    Next
End Function

Public Function Items(): ReDim t(1 To elements.Count): For Each elem In elements: i = i + 1: t(i) = elem.item: Next: Items = t: End Function

Public Function Keys(): ReDim t(1 To elements.Count): For Each elem In elements: i = i + 1: t(i) = elem.key: Next: Keys = t:: End Function

Public Function ToTable(): ReDim t(1 To elements.Count, 1 To 2): For Each elem In elements: i = i + 1: t(i, 1) = elem.key: t(i, 2) = elem.item: Next: ToTable = t: End Function

Dim dico As dictionnaire
Sub ecriture()
    Set dico = New dictionnaire
    dico.Add "toto", "28"
    dico.Add "titi", "54"
    dico.Add "riri", "48"
    dico.Add "toto", "22"
    If dico.Exists("toto") = 0 Then dico.Add "toto", "74"
End Sub

Sub lecture()
    If dico.elements.Count = 0 Then MsgBox "le dico est vide": Exit Sub
    For Each elem In dico.elements
        MsgBox "key: " & elem.key & "--item: " & elem.item
    Next
End Sub

' lecture des clé et items
Sub lecture2()
    If dico.elements.Count = 0 Then MsgBox "le dico est vide": Exit Sub
    MsgBox Join(dico.Keys, vbCrLf)
End Sub

Sub lecture3()
    If dico.elements.Count = 0 Then MsgBox "le dico est vide": Exit Sub
    MsgBox Join(dico.Items, vbCrLf)
End Sub

Sub dicototable()
    If dico.elements.Count = 0 Then MsgBox "le dico est vide": Exit Sub
    x = dico.ToTable
    Cells(1, 1).Resize(UBound(x), 2) = x
End Sub

Private Key
Private Item

Private Sub Class_Initialize()
    Dim t(), t2(): ReDim Preserve t(0): ReDim Preserve t2(0): Key = t: Item = t2
End Sub

Public Function Add(k As String, Optional i As Variant = "", Optional ByVal Overwrite_Item As Boolean = True)
     x = Application.IfError(Application.Match(k, Key, 0), 0)
    If x = 0 Then
        a = UBound(Key) + 1: ReDim Preserve Key(1 To a): ReDim Preserve Item(1 To a): Key(a) = k: Item(a) = i
    Else
        If Overwrite_Item Then Item(x) = i
    End If
End Function

Public Function keys(Optional k As String = "")
    If k = "" Then keys = Key Else For i = 1 To UBound(Key): keys = IIf(Key(i) = k, Item(i), ""): Next
End Function
Public Function items(Optional it As String = "")
    If it = "" Then
        items = Item
    Else: For i = 1 To UBound(Item)
            If Item(i) = it Then items = Key(i)
        Next
    End If
End Function

Function Sort()
    Dim temp, temp2, i&, a&
    For i = 1 To UBound(Key) - 1
        For a = i + 1 To UBound(Key)
            If Key(i) > Key(a) Then
                temp = Key(i): temp2 = Item(i)
                Key(i) = Key(a): Key(a) = temp
                Item(i) = Item(a): Item(a) = temp2
            End If
        Next
    Next
End Function

Dim dico As dictionary
Sub dest()
    Dim k, it
    Set dico = New dictionary
    dico.Add "toto", "25"
    dico.Add "lolo", "33"
    dico.Add "fifi", "42"
    dico.Add "toto", "39", False

    dico.Sort

    k = dico.keys: it = dico.items
    txt = vbTab & vbCrLf
    For i = 1 To UBound(k)
        txt = txt & "key: = " & k(i) & "   item: = " & it(i) & vbCrLf
    Next


    MsgBox txt

    MsgBox "la clé toto donne " & dico.keys("toto")

    MsgBox "l 'item 33 donne " & dico.items(33)
End Sub