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

Вход

Регистрация

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

 

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

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

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

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

Сортировки массивов. Быстрая сортировка (для двумерного массива)
30.12.2013, 23:48
[ Файл-пример (27.0 Kb) ]
В качестве примера - Выделить повторяющиеся значения в столбце
'автор кода Слэн (кажется)
Private Type QuickStack 'тип для QuickSort
 Low As Long
 High As Long
End Type

Public Sub sort_range(ByRef SortArray(), Optional ByVal col = 1)
On Error Resume Next
If UBound(SortArray, 2) > 2 Then Exit Sub
Dim i As Long, j As Long, lb As Long, ub As Long, dc&
Dim stack() As QuickStack, stackpos As Long, ppos As Long, pivot As Variant, swp, maxstack&
On Error GoTo er
lb = LBound(SortArray): ub = UBound(SortArray): dc = UBound(SortArray, 2) + 1 - col
ReDim stack(1 To 16)
stackpos = 1

stack(1).Low = lb
stack(1).High = ub
Do
 lb = stack(stackpos).Low 'Взять границы lb и ub текущего массива из стека.
 ub = stack(stackpos).High
 stackpos = stackpos - 1
 Do
 ppos = (lb + ub) \ 2 'Шаг 1. Разделение по элементу pivot
 i = lb: j = ub: pivot = SortArray(ppos, col)
 Do
 While SortArray(i, col) < pivot: i = i + 1: Wend
 While pivot < SortArray(j, col): j = j - 1: Wend
 If i > j Then Exit Do
 ' If i <> j Then
 swp = SortArray(i, col): SortArray(i, col) = SortArray(j, col): SortArray(j, col) = swp
 swp = SortArray(i, dc): SortArray(i, dc) = SortArray(j, dc): SortArray(j, dc) = swp
 ' End If
 i = i + 1
 j = j - 1
 ' End If
 Loop While i <= j

 If i < ppos Then 'правая часть больше
 If i < ub Then
 stackpos = stackpos + 1
 stack(stackpos).Low = i
 stack(stackpos).High = ub
 End If
 ub = j 'следующая итерация разделения будет работать с левой частью
 Else
 If j > lb Then
 stackpos = stackpos + 1
 stack(stackpos).Low = lb
 stack(stackpos).High = j
 End If
 lb = i
 End If
 ' If maxstack < stackpos Then maxstack = stackpos
 Loop While lb < ub
Loop While stackpos
Exit Sub
er: ReDim Preserve stack(1 To UBound(stack) * 2)
Resume
End Sub
Добавил: nilem |
Просмотров: 7075 | Рейтинг: 5.0/3
Всего комментариев: 0
Добавлять комментарии могут только зарегистрированные пользователи.
[ Регистрация | Вход ]
Яндекс.Метрика Яндекс цитирования
© 2010-2024 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!