Sort array - Fast

[LeandroA]

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


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