Не сочтите за нарушение. Нашел на другом форуме отличный алгоритм Вот ссылка на пост sql.ru
Добавил к себе вот такой слегка видоизмененный кусок кода [vba]
Код
Type QuickStack 'тип для QuickSort Low As Long High As Long End Type Sub QuickSortNonRecursive(ByRef SortArray(), Optional Descending As Boolean) Dim i As Long, j As Long, lb As Long, ub As Long Dim stack() As QuickStack, stackpos As Long, maxstackpos As Long, stposArrMax As Long, ppos As Long, pivot As Variant, swp
stackpos = 1 maxstackpos = 1 stack(1).Low = lb stack(1).High = ub Do lb = stack(stackpos).Low ub = stack(stackpos).High stackpos = stackpos - 1 Do ppos = (lb + ub) \ 2 i = lb: j = ub: pivot = SortArray(ppos) Do While IIf(Descending, SortArray(i) > pivot, SortArray(i) < pivot): i = i + 1: Wend While IIf(Descending, pivot > SortArray(j), pivot < SortArray(j)): j = j - 1: Wend If i > j Then Exit Do swp = SortArray(i): SortArray(i) = SortArray(j): SortArray(j) = swp i = i + 1 j = j - 1 Loop While i <= j
If i < ppos Then stackpos = stackpos + 1 If stackpos > maxstackpos Then maxstackpos = stackpos If stackpos > stposArrMax Then stposArrMax = stposArrMax * 2: ReDim Preserve stack(stposArrMax) stack(stackpos).Low = i stack(stackpos).High = ub ub = j Else If j > lb Then stackpos = stackpos + 1 If stackpos > maxstackpos Then maxstackpos = stackpos If stackpos > stposArrMax Then stposArrMax = stposArrMax * 2: ReDim Preserve stack(stposArrMax) stack(stackpos).Low = lb stack(stackpos).High = j End If lb = i End If Loop While lb < ub Loop While stackpos End Sub
[/vba]
Заполняю одномерный массив датами и передаю в процедуру QuickSortNonRecursive()
[vba]
Код
Dim i, z As Integer Dim ArrName(5) As Variant ' Заполняем массив както-так... For z = 1 To 5 ArrName(z-1) = ....дата Next z 'Сортируем массив Call QuickSortNonRecursive(ArrName)
i = y 'Заполняем ListBox в обратной последовательности, не обязательно, можно воспользоваться параметром Descending в процедуре Do While i > 0 ListBox1.AddItem (CStr(ArrName(i))) i = i - 1 Loop
[/vba]
Не сочтите за нарушение. Нашел на другом форуме отличный алгоритм Вот ссылка на пост sql.ru
Добавил к себе вот такой слегка видоизмененный кусок кода [vba]
Код
Type QuickStack 'тип для QuickSort Low As Long High As Long End Type Sub QuickSortNonRecursive(ByRef SortArray(), Optional Descending As Boolean) Dim i As Long, j As Long, lb As Long, ub As Long Dim stack() As QuickStack, stackpos As Long, maxstackpos As Long, stposArrMax As Long, ppos As Long, pivot As Variant, swp
stackpos = 1 maxstackpos = 1 stack(1).Low = lb stack(1).High = ub Do lb = stack(stackpos).Low ub = stack(stackpos).High stackpos = stackpos - 1 Do ppos = (lb + ub) \ 2 i = lb: j = ub: pivot = SortArray(ppos) Do While IIf(Descending, SortArray(i) > pivot, SortArray(i) < pivot): i = i + 1: Wend While IIf(Descending, pivot > SortArray(j), pivot < SortArray(j)): j = j - 1: Wend If i > j Then Exit Do swp = SortArray(i): SortArray(i) = SortArray(j): SortArray(j) = swp i = i + 1 j = j - 1 Loop While i <= j
If i < ppos Then stackpos = stackpos + 1 If stackpos > maxstackpos Then maxstackpos = stackpos If stackpos > stposArrMax Then stposArrMax = stposArrMax * 2: ReDim Preserve stack(stposArrMax) stack(stackpos).Low = i stack(stackpos).High = ub ub = j Else If j > lb Then stackpos = stackpos + 1 If stackpos > maxstackpos Then maxstackpos = stackpos If stackpos > stposArrMax Then stposArrMax = stposArrMax * 2: ReDim Preserve stack(stposArrMax) stack(stackpos).Low = lb stack(stackpos).High = j End If lb = i End If Loop While lb < ub Loop While stackpos End Sub
[/vba]
Заполняю одномерный массив датами и передаю в процедуру QuickSortNonRecursive()
[vba]
Код
Dim i, z As Integer Dim ArrName(5) As Variant ' Заполняем массив както-так... For z = 1 To 5 ArrName(z-1) = ....дата Next z 'Сортируем массив Call QuickSortNonRecursive(ArrName)
i = y 'Заполняем ListBox в обратной последовательности, не обязательно, можно воспользоваться параметром Descending в процедуре Do While i > 0 ListBox1.AddItem (CStr(ArrName(i))) i = i - 1 Loop