Sort array - Fast

This method uses a parallel array that stores the id of the original array sorted correctly. to make the comparison does not go through the entire array,it is split into two to find your nearest location.

To test the sample to insert a ListBox, a CommandButton, a CheckBox, and Three OptionButton with index of 0 to 2

Code:

---

Option Explicit
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)
Private Declare Function GetTickCount Lib "kernel32.dll" () As Long


Private Type MyType
    Name As String
    Birthday As Date
    Age As Long
End Type

Dim m_OrderBy As Integer

Private MT() As MyType

Private Sub Command1_Click()
    Dim SortedArray() As Long
    Dim TempMT() As MyType
    Dim DescendingOrder As Boolean
    Dim LenMyArray As Long
    Dim i As Long

    Dim t As Long
   
    t = GetTickCount
   
    LenMyArray = UBound(MT)
       
    SortedArray = OrderedArray(LenMyArray)
       
       
    ReDim TempMT(UBound(MT))
   
    DescendingOrder = Check1.Value
   
    If DescendingOrder Then
        For i = 0 To LenMyArray
            TempMT(LenMyArray - i) = MT(SortedArray(i))
        Next
    Else
        For i = 0 To LenMyArray
            TempMT(i) = MT(SortedArray(i))
        Next
    End If
   
    MT = TempMT
   
    MsgBox "Time: " & GetTickCount - t
   
    List1.Clear
   

    For i = 0 To LenMyArray
        List1.AddItem MT(i).Name & Space(10) & MT(i).Birthday & Space(10) & MT(i).Age
    Next


End Sub

Private Function OrderedArray(ByVal UBoundArray As Long) As Long()
    Dim Index As Long, i As Long
    Dim Arr() As Long, LenArray As Long, TempArr() As Long
    Dim nInf As Long, nSup As Long, nMid As Long
   
    ReDim Arr(0)

    For Index = 1 To UBoundArray
       
        If GetVar(Arr(UBound(Arr))) <= GetVar(Index) Then
            ReDim Preserve Arr(UBound(Arr) + 1)
            Arr(UBound(Arr)) = Index
        Else
       
            nInf = 0
            nSup = UBound(Arr)
       
            Do
                nMid = (nSup - nInf) \ 2
           
                Do
                    If GetVar(Arr(nMid)) <= GetVar(Index) Then
                        nInf = nMid - 1
                        nMid = nMid + ((nSup - nInf) \ 2)
                    Else
                        nSup = nMid
                        Exit Do
                    End If
                Loop
               
                If nInf < 0 Then nInf = 0: Exit Do
               
               
                If nSup - nInf < 4 Then Exit Do
            Loop
               
       
            For i = nInf To nSup
                If GetVar(Arr(i)) >= GetVar(Index) Then
               
                    LenArray = UBound(Arr) + 1
                   
                    ReDim TempArr(LenArray)
                    If i > 0 Then CopyMemory TempArr(0), Arr(0), 4 * i
                    TempArr(i) = Index
                    CopyMemory TempArr(i + 1), Arr(i), 4 * (LenArray - i)
                    ReDim Arr(LenArray)
                    CopyMemory Arr(0), TempArr(0), 4 * (LenArray + 1)

                    Exit For
                End If
            Next
           
        End If
    Next
   
    OrderedArray = Arr
   
End Function


'Private Function GetVar(ByVal Index As Long) As Variant
'    Dim Value As String
   
'    Value = MT(Index).Caption

'    If IsNumeric(Value) Then
'        GetVar = Val(Value)
'    Else
'        If IsDate(Value) Then
'            GetVar = CDate(Value)
'        Else
'            GetVar = CStr(Value)
'        End If
'    End If
'End Function


'--------------------------------------
'Change this function for your use
'---------------------------------------
Private Function GetVar(ByVal Index As Long) As Variant
    Select Case m_OrderBy
        Case 0
            GetVar = MT(Index).Name
        Case 1
            GetVar = MT(Index).Birthday
        Case 2
            GetVar = MT(Index).Age
    End Select
End Function

Private Sub Option1_Click(Index As Integer)
    m_OrderBy = Index
End Sub


Private Sub Form_Load()
    Dim i As Long
   
    ReDim MT(10000)
   
    List1.FontName = "MS Mincho"
   
    Randomize

    For i = 0 To 10000
        MT(i).Name = GetRndName
        MT(i).Birthday = GetRandom(CDate("01/01/1930"), CDate("01/01/1995"))
        MT(i).Age = (Date - MT(i).Birthday) / 365
        List1.AddItem MT(i).Name & Space(10) & MT(i).Birthday & Space(10) & MT(i).Age
    Next
   
    Option1(0).Caption = "Name": Option1(0).Value = True
    Option1(1).Caption = "Birthday"
    Option1(2).Caption = "Age"
    Check1.Caption = "DescendingOrder"
    Command1.Caption = "Ordered"
End Sub

Private Function GetRndName() As String
    Dim i As Long
    For i = 1 To 6
        GetRndName = GetRndName & Chr(GetRandom(91, 64))
    Next
End Function

Private Function GetRandom(ByVal Lower As Variant, ByVal Upper As Variant) As Variant
    GetRandom = Int((Upper - Lower + 1) * Rnd() + Lower)
End Function

---

have to be modified to implement the function getVar this is what is responsible for obtaining the variable of our UDT or Array.

OrderedArray function is that returns the sorted array with the index and well within the event command1 can see how it is used.

I accept suggestions or criticism