Hola, al fin pude hacer un ordenamiento de un array que sea rápido. voy a tratar de explicar un poco como funciona anteriormente utilizaba un método como
este para ordenar un array y era muy lento, luego BlackZeroX▓▓▒▒░░ me sugirio
este otro método en donde ya se puede ordenar numericamente, pero sigue siendo lento. asi que decidi intentar de otra forma.
Este método utiliza un array paralelo que almacena los id del array original ordenados correctamente usando
esta forma para poder insertar las ubicaciones. para hacer la comparación no recorre todo el array sino que lo va dividiendo en dos hasta encontrar su ubicación mas cercana.
para probar el ejemplo insertar un ListBox , un CommandButton, un CheckBox, y Tres OptionButton con index del 0 al 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 "Tiempo de ordenado: " & 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
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 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 = "Nombre": Option1(0).Value = True
Option1(1).Caption = "Fehca de Nacimiento"
Option1(2).Caption = "Edad"
Check1.Caption = "Desendente"
Command1.Caption = "Ordenar"
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
Private Sub Option1_Click(Index As Integer)
m_OrderBy = Index
End Sub
si quieren usar esta funcion para algun proyecto lo que tienen que modificar es la funcion
GetVar esta es la que se encarga de obtener la variable de nuestro UDT o Array.
La función
OrderedArray es la que devuelve el array con los index ordenados y bien dentro del evento command1 pueden ver como se utiliza.
Saludos.
