Сортировка словаря методом реконструкции

Private Declare PtrSafe Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
 
Private Type tpPrev
    Ptr As LongPtr
    Prv As LongPtr
End Type
 
#If Win64 Then
    Private Const ptrSz = 8
    Private Const pvDataOffset = 16
#Else
    Private Const ptrSz = 4
    Private Const pvDataOffset = 12
#End If
 
Dim p As Long, RestPtrStack() As tpPrev, pPtr() As LongPtr, Ptr() As LongPtr
Dim x
 
Sub Пример()
    Dim Arr()
    PtrInit
    x = vbNullString
    
    ReDim Arr(4)
    Arr(0) = "cc"
    Arr(1) = "ii"
    Arr(2) = "n"
    Arr(3) = "aa"
    Arr(4) = "l"
    PRDX_SortRecur_a1D_TU_PtrVarStr Arr, 0, 4
    
    pPtr(0) = VarPtr(x) + 8: Ptr(0) = 0
    ReleaseAllPtrs
End Sub
 
Sub PRDX_SortRecur_a1D_TU_PtrVarStr(a1D(), LBnd&, UBnd&)
Dim i&, j&, pTmp As LongPtr ', x, y
 
i = LBnd: j = UBnd ': x = a1D((LBnd + UBnd) \ 2)
pPtr(0) = VarPtr(x) + 8: Ptr(0) = StrPtr(a1D((LBnd + UBnd) \ 2))
 
Do
    While a1D(i) < x: i = i + 1: Wend
    While x < a1D(j): j = j - 1: Wend
    If i <= j Then
'        y = a1D(i): a1D(i) = a1D(j): a1D(j) = y
        pPtr(0) = VarPtr(a1D(i)) + 8: pTmp = Ptr(0): Ptr(0) = StrPtr(a1D(j))
        pPtr(0) = VarPtr(a1D(j)) + 8: Ptr(0) = pTmp
        i = i + 1: j = j - 1
    End If
Loop Until i > j
 
If LBnd < j Then PRDX_SortRecur_a1D_TU_PtrVarStr a1D, LBnd, j
If i < UBnd Then PRDX_SortRecur_a1D_TU_PtrVarStr a1D, i, UBnd
End Sub
 
Sub PtrInit()
    Dim ppvData1 As LongPtr, ppvData2 As LongPtr
    ReDim RestPtrStack(1): ReDim pPtr(0): ReDim Ptr(0)
    CopyMemory ppvData1, ByVal VarPtr(p) + ptrSz * 2, ptrSz
    ppvData1 = ppvData1 + pvDataOffset
    RestPtrStack(0).Ptr = ppvData1
    RestPtrStack(0).Prv = VarPtr(pPtr(0))
    CopyMemory ppvData2, ByVal VarPtr(p) + ptrSz * 3, ptrSz
    ppvData2 = ppvData2 + pvDataOffset
    RestPtrStack(1).Ptr = ppvData2
    RestPtrStack(1).Prv = VarPtr(Ptr(0))
    CopyMemory ByVal ppvData1, ppvData2, ptrSz
End Sub
 
Sub ReleaseAllPtrs()
    Dim i&
    For i = 0 To UBound(RestPtrStack)
        CopyMemory ByVal RestPtrStack(i).Ptr, RestPtrStack(i).Prv, ptrSz
    Next
End Sub