Как получить название ключа в коллекции

Option Explicit
 
Private CL As Collection
Function Keys()
'Вот тут я остановился
'    Dim f&, v, v1
'    ReDim v(CL.Count - 1)
'    For Each v1 In CL
'        v(f) = CL(f + 1)
'        f = f + 1
'    Next
End Function
 
Public Sub Add(Key$, Item)
    CL.Add Item, Key
End Sub
 
Function Exists(Key) As Boolean
    On Error Resume Next
    Call CL.Item(Key)
    If Err.Number Then Else Exists = True
End Function
 
Function Items() As Variant()
    Dim f&, v, v1
    ReDim v(CL.Count - 1)
    For Each v1 In CL
        v(f) = v1
        f = f + 1
    Next
End Function
 
Private Sub Class_Initialize()
    Set CL = New Collection
End Sub
 
Private Sub Class_Terminate()
    Set CL = Nothing
End Sub

Option Explicit
 
Private Type tPointer
    Hash As Integer
    Index As Integer
End Type
Private Type tElement
    Key As String
    Value As String
    Next As tPointer
    Prev As tPointer
End Type
Private Type tItem
    ElementsCount As Long
    Elements() As tElement
End Type
 
Private Dat() As tItem
Private mCount As Long
Private mCompareMethod As VbCompareMethod
Private First As tPointer, Last As tPointer
 
Public Property Get CompareMethod() As VbCompareMethod
    CompareMethod = mCompareMethod
End Property
Public Property Let CompareMethod(ByVal Value As VbCompareMethod)
    If mCount Then Err.Raise 5: Exit Property    ' Òîëüêî êîãäà ýëåìåíòîâ íåò
    mCompareMethod = Value
End Property
Public Sub Add(Key As String, Value As String)
    Dim pt As tPointer
    pt = GetFromKey(Key)
    If pt.Index <> -1 Then Err.Raise 457: Exit Sub
    pt.Index = Dat(pt.Hash).ElementsCount
    ReDim Preserve Dat(pt.Hash).Elements(pt.Index)
    Dat(pt.Hash).ElementsCount = pt.Index + 1
    Dat(pt.Hash).Elements(pt.Index).Value = Value
    Dat(pt.Hash).Elements(pt.Index).Key = Key
    
    If Last.Hash >= 0 Then
        Dat(Last.Hash).Elements(Last.Index).Next = pt
        Dat(pt.Hash).Elements(pt.Index).Prev = Last
    Else
        Dat(pt.Hash).Elements(pt.Index).Prev.Hash = -1
        Dat(pt.Hash).Elements(pt.Index).Prev.Index = -1
        First = pt
    End If
    Dat(pt.Hash).Elements(pt.Index).Next.Hash = -1
    Dat(pt.Hash).Elements(pt.Index).Next.Index = -1
    Last = pt
    mCount = mCount + 1
End Sub
Public Property Get Item(Key As String) As String
    Dim pt As tPointer
    pt = GetFromKey(Key): If pt.Index = -1 Then Err.Raise 5: Exit Property
    Item = Dat(pt.Hash).Elements(pt.Index).Value
End Property
Public Property Let Item(Key As String, Value As String)
    Dim pt As tPointer
    pt = GetFromKey(Key): If pt.Index = -1 Then Err.Raise 5: Exit Property
    Dat(pt.Hash).Elements(pt.Index).Value = Value
End Property
Public Property Get Count() As Long
    Count = mCount
End Property
Public Function Exist(Key As String) As Boolean
    Exist = GetFromKey(Key).Index <> -1
End Function
Public Sub Remove(Key As String)
    Dim pt As tPointer, l As Long, ln As tPointer, lp As tPointer, p As tPointer
    pt = GetFromKey(Key): If pt.Index = -1 Then Err.Raise 5: Exit Sub
    lp = Dat(pt.Hash).Elements(pt.Index).Prev: ln = Dat(pt.Hash).Elements(pt.Index).Next
    For l = pt.Index To Dat(pt.Hash).ElementsCount - 2
        Dat(pt.Hash).Elements(l) = Dat(pt.Hash).Elements(l + 1)
        ' Ïðàâèì ññûëêè íà ýëåìåíò
        p = Dat(pt.Hash).Elements(l).Prev
        If p.Index >= 0 Then Dat(p.Hash).Elements(p.Index).Next.Index = Dat(p.Hash).Elements(p.Index).Next.Index - 1
        p = Dat(pt.Hash).Elements(l).Next
        If p.Index >= 0 Then Dat(p.Hash).Elements(p.Index).Prev.Index = Dat(p.Hash).Elements(p.Index).Prev.Index - 1
    Next
    l = Dat(pt.Hash).ElementsCount - 1: Dat(pt.Hash).ElementsCount = l
    If l Then
        ReDim Preserve Dat(pt.Hash).Elements(l - 1)
    Else
        Erase Dat(pt.Hash).Elements()
    End If
    ' Ïðàâèì ññûëêè
    If lp.Index >= 0 Then Dat(lp.Hash).Elements(lp.Index).Next = ln
    If ln.Index >= 0 Then Dat(ln.Hash).Elements(ln.Index).Prev = lp
    If lp.Index = -1 Then First = ln
    If ln.Index = -1 Then Last = lp
    mCount = mCount - 1
End Sub
Public Sub Clear()
    Call Class_Initialize
End Sub
Public Function HashValue(S As String) As Long
    Dim i As Long, ch As Integer
    For i = 0 To Len(S) - 1
        HashValue = (HashValue * 11 + AscW(LCase(Mid$(S, i + 1, 1)))) And &HFFFF&
    Next
    HashValue = HashValue Mod 999
End Function
Public Function Items() As String()
    Dim pt As tPointer, i As Long, ret() As String
    If mCount = 0 Then Exit Function
    pt = First: ReDim ret(mCount - 1)
    Do
        ret(i) = Dat(pt.Hash).Elements(pt.Index).Value
        pt = Dat(pt.Hash).Elements(pt.Index).Next
        i = i + 1
    Loop While i < mCount
    Items = ret
End Function
Public Function Keys() As String()
    Dim pt As tPointer, i As Long, ret() As String
    If mCount = 0 Then Exit Function
    pt = First: ReDim ret(mCount - 1)
    Do
        ret(i) = Dat(pt.Hash).Elements(pt.Index).Key
        pt = Dat(pt.Hash).Elements(pt.Index).Next
        i = i + 1
    Loop While i < mCount
    Keys = ret
End Function
Private Function GetFromKey(K As String) As tPointer
    Dim i As Long, h As Long
    h = HashValue(K): GetFromKey.Hash = h
    For i = 0 To Dat(h).ElementsCount - 1
        If StrComp(Dat(h).Elements(i).Key, K, mCompareMethod) = 0 Then GetFromKey.Index = i: Exit Function
    Next
    GetFromKey.Index = -1
End Function
Private Sub Class_Initialize()
    ReDim Dat(998): First.Hash = -1: First.Index = -1: Last.Hash = -1: Last.Index = -1
End Sub
Private Sub Class_Terminate()
    Erase Dat()
End Sub

Public Property Let Key(ByVal Key$, ByVal vNewValue As String)
    Dim v, v1, v2, f&
    v = c1(Key)
    v1 = Keys: v2 = Items
    Set c1 = Nothing: Set c1 = New Collection
    For f = 0 To UBound(v1)
        If StrComp(v1(f), Key, 1) = 0 Then
            c1.Add v2(f), vNewValue
        Else
            c1.Add v2(f), v1(f)
        End If
    Next
End Property

    Dim v
    v = c1(Key)
    c1.Remove (Key)
    c1.Add v, vNewValue

Public Property Get Item(Key) As Variant
    If IsObject(c1(Key)) Then Set Item = c1(Key) Else Item = c1(Key)
End Property

Option Explicit
 
Private Sub Form_Load()
    Dim Col As clsMyCollection, Itm As Variant
 
    Set Col = New clsMyCollection
    ' Перечисление
    For Each Itm In Col
        Debug.Print Itm
    Next
End Sub

Private Declare PtrSafe Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
#If Win64 Then
    Private Const ptrSz = 8
    Private Const varSz = 24
    Private Const collPtrOffset = 40
#Else
    Private Const ptrSz = 4
    Private Const varSz = 16
    Private Const collPtrOffset = 24
#End If
Private Function CollKey(ByVal Index As Long, Coll As Collection) As String
    Dim i As Long, Ptr0 As LongPtr, Ptr As LongPtr, Key As String
    If Coll Is Nothing Then Exit Function
    Select Case Index
    Case Is < 1, Is > Coll.Count: Exit Function
    Case Else
        Ptr = ObjPtr(Coll)
        For i = 1 To Index
            CopyMemory Ptr, ByVal Ptr + collPtrOffset, ptrSz
        Next
        CopyMemory ByVal VarPtr(Key), ByVal Ptr + varSz, ptrSz
        CollKey = Key
        CopyMemory ByVal VarPtr(Key), Ptr0, ptrSz
    End Select
End Function

Private Type tpCollElem
    item As Variant
    Key As String
    prvPtr As LongPtr
    nxtPtr As LongPtr
End Type
 
Private Function CollKey2(ByVal Index As Long, Coll As Collection) As String
    Dim collElem As tpCollElem
    CollKey2_ Index, Coll, CollKey2, collElem
End Function
Private Sub CollKey2_(ByVal Index As Long, Coll As Collection, Key As String, collElem As tpCollElem, _
                      Optional Ptr As LongPtr, Optional pPtr As LongPtr)
    Dim i As Long, lpTmp As LongPtr
    If Coll Is Nothing Then Exit Sub
    Select Case Index
    Case Is < 1, Is > Coll.Count: Exit Sub
    Case Else
        CopyMemory ByVal VarPtr(Index) + ptrSz * 5, VarPtr(Index) + ptrSz * 4, ptrSz
        pPtr = ObjPtr(Coll) + collPtrOffset: lpTmp = Ptr
        pPtr = VarPtr(Index) + ptrSz * 3: Ptr = lpTmp
        For i = 2 To Index
            Ptr = collElem.nxtPtr
        Next
        Key = collElem.Key
    End Select
End Sub