Домашняя страница Undo Do Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Готовые решения

МЕНЮ САЙТА
  • 1
  • 2
  • 3

КАТЕГОРИИ РАЗДЕЛА

ОПРОСЫ
Какой версией Excel Вы пользуетесь?
Всего ответов: 35789
Главная » Готовые решения » VBA » Полезные приёмы

Сортировки массивов. Быстрая сортировка (вариант для одномерного массива).
27.10.2013, 00:02
Quick Sort в редакции mikerickson
Dim LStack() As Long, HStack() As Long
Dim SPointer As Long

Sub test() 'option from mikerickson
Dim xRRay As Variant
With Sheets("Sheet1").Range("A:A")
 With Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
 xRRay = Application.Transpose(.Value)
 SortArray xRRay, True
 .Offset(0, 1).Value = Application.Transpose(xRRay)
 End With
End With
End Sub
Sub SortArray(ByRef myArray As Variant, Descending As Boolean)
Dim Low As Long, High As Long
Dim LookingAt As Long, PivotPlace As Long
Dim pivotVal As Variant
Dim pivotChoosing As Boolean

Low = LBound(myArray)
High = UBound(myArray)
Push Low, High

Do Until SPointer <= 0
 Pop Low, High
 'If pivotChoosing Then
 Swap myArray, High, (Low + High) / 2
 'End If

 pivotVal = myArray(High)
 PivotPlace = Low
 For LookingAt = Low To High - 1
 If LT(myArray(LookingAt), pivotVal) Xor Descending Then
 Swap myArray, PivotPlace, LookingAt
 PivotPlace = PivotPlace + 1
 End If
 Next LookingAt
 Swap myArray, High, PivotPlace

 If Low < PivotPlace - 1 Then Push Low, PivotPlace - 1
 If PivotPlace + 1 < High Then Push PivotPlace + 1, High
Loop
End Sub
Sub Swap(ByRef inRRay As Variant, A As Long, B As Long)
 Dim temp As Variant
 temp = inRRay(A)
 inRRay(A) = inRRay(B)
 inRRay(B) = temp
End Sub
Sub Push(ByRef A As Long, ByRef B As Long)
 SPointer = SPointer + 1
 On Error GoTo EnlargeStack
 
 LStack(SPointer) = A
 HStack(SPointer) = B
 Exit Sub
EnlargeStack:
 Err.Clear
 On Error GoTo InitializeStack
 ReDim Preserve LStack(0 To 2 * SPointer)
 ReDim Preserve HStack(0 To 2 * SPointer)
 Resume
InitializeStack:
 Err.Clear
 ReDim LStack(0 To 0)
 ReDim HStack(0 To 0)
 SPointer = 1
 Resume
End Sub
Sub Pop(ByRef A As Long, B As Long)
 A = LStack(SPointer)
 B = HStack(SPointer)
 SPointer = SPointer - 1
End Sub
Function LT(A As Variant, B As Variant) As Boolean
 LT = A < B
End Function
Добавил: nilem | | Теги: array, VBA, sort, quick, Transpose
Просмотров: 3206 | Рейтинг: 0.0/0
Всего комментариев: 0
Добавлять комментарии могут только зарегистрированные пользователи.
[ Регистрация | Вход ]
Яндекс цитирования
© 2010-2016 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!