MyTetra Share
Делитесь знаниями!
Сортировка2
Время создания: 31.07.2019 22:59
Текстовые метки: Фильтр, Filter, AutoFilter, Mode, AutoFilterMode, Sort
Раздел: !Закладки - VBA - Excel - Листы - Фильтр-сортировка
Запись: adgaver/mytetra_base_New/master/base/1511255857o4bsrppnnl/text.html на raw.githubusercontent.com


На листе:


2

a

1

4

b

2

1

c

3

5

d

4

8

e

5

7

f

6

3

g

7

6

h

8

9

i

9


Private Type QuickStack

'тип для QuickSort

Low As Long

High As Long

End Type


'=========================================================================================================

Public Sub QuickSortNonRecursive_a(SortArray())

Dim i As Long, j As Long, lb As Long, ub As Long

Dim stack() As QuickStack, stackpos As Long, ppos As Long, pivot As Variant, swp, maxstack&

On Error GoTo er

ReDim stack(1 To 16)

stackpos = 1


stack(1).Low = LBound(SortArray)

stack(1).High = UBound(SortArray)

Do

'Взять границы lb и ub текущего массива из стека.

lb = stack(stackpos).Low

ub = stack(stackpos).High

stackpos = stackpos - 1

Do

'Шаг 1. Разделение по элементу pivot

ppos = (lb + ub) \ 2

i = lb: j = ub: pivot = SortArray(ppos)

Do

While SortArray(i) < pivot: i = i + 1: Wend

While pivot < SortArray(j): j = j - 1: Wend

If i > j Then Exit Do

If i = j Then

i = i + 1

j = j - 1

Exit Do

End If

swp = SortArray(i): SortArray(i) = SortArray(j): SortArray(j) = swp

i = i + 1

j = j - 1

Loop 'While i <= j


'Сейчас указатель i указывает на начало правого подмассива,

'j - на конец левого lb ? j ? i ? ub.

'Возможен случай, когда указатель i или j выходит за границу массива

'Шаги 2, 3. Отправляем большую часть в стек и двигаем lb,ub


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

' Debug.Print maxstack

End Sub




'=========================================================================================================

Public Sub QuickSortNonRecursive_ia(ByRef SortArray(), ByRef r() As Long, Optional ByVal col = 1)

Dim i As Long, j As Long, lb As Long, ub As Long

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)

ReDim stack(1 To 16)

' stackpos = 0


stack(1).Low = lb

stack(1).High = ub

'Шаг 1. Разделение по элементу pivot

ppos = (lb + ub) \ 2

i = lb: j = ub: pivot = SortArray(ppos, col)

Do

While SortArray(i, col) < pivot: r(i) = i: i = i + 1: Wend

While pivot < SortArray(j, col): r(j) = j: j = j - 1: Wend

If i > j Then Exit Do

If i = j Then

r(i) = i

i = i + 1

j = j - 1

Exit Do

End If

swp = SortArray(i, col): SortArray(i, col) = SortArray(j, col): SortArray(j, col) = swp

r(i) = j: r(j) = i

i = i + 1

j = j - 1

Loop 'While i <= j


'Сейчас указатель i указывает на начало правого подмассива,

'j - на конец левого lb ? j ? i ? ub.

'Возможен случай, когда указатель i или j выходит за границу массива

'Шаги 2, 3. Отправляем большую часть в стек и двигаем lb,ub


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

If lb >= ub Then Exit Sub

Do

'Взять границы lb и ub текущего массива из стека.

lb = stack(stackpos).Low

ub = stack(stackpos).High

stackpos = stackpos - 1

Do

'Шаг 1. Разделение по элементу pivot

ppos = (lb + ub) \ 2

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

r(i) = i

i = i + 1

j = j - 1

Exit Do

End If

swp = SortArray(i, col): SortArray(i, col) = SortArray(j, col): SortArray(j, col) = swp

swp = r(i): r(i) = r(j): r(j) = swp

i = i + 1

j = j - 1

Loop 'While i <= j


'Сейчас указатель i указывает на начало правого подмассива,

'j - на конец левого lb ? j ? i ? ub.

'Возможен случай, когда указатель i или j выходит за границу массива

'Шаги 2, 3. Отправляем большую часть в стек и двигаем lb,ub


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

' Debug.Print maxstack

End Sub



'=========================================================================================================

Public Sub QuickSortNonRecursive_2a(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 и ub текущего массива из стека.

lb = stack(stackpos).Low

ub = stack(stackpos).High

stackpos = stackpos - 1

Do

'Шаг 1. Разделение по элементу pivot

ppos = (lb + ub) \ 2

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

i = i + 1

j = j - 1

Exit Do

End If

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

i = i + 1

j = j - 1

Loop 'While i <= j


'Сейчас указатель i указывает на начало правого подмассива,

'j - на конец левого lb ? j ? i ? ub.

'Возможен случай, когда указатель i или j выходит за границу массива

'Шаги 2, 3. Отправляем большую часть в стек и двигаем lb,ub


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

' Debug.Print maxstack

End Sub



'=========================================================================================================

Sub sort_range(ByRef arr(), Optional ByVal col& = 1, Optional ByVal ascending As Boolean = True)

Dim nu&, nl&, i&, j&, rl&, ru&, i_arr&(), rez()

On Error GoTo er1

nu = UBound(arr, 2)

nl = LBound(arr, 2)

On Error GoTo er2

rl = LBound(arr)

ru = UBound(arr)

If (nu - nl) = 1 Then

If ascending Then

Call QuickSortNonRecursive_2a(arr, col)

Else

Call QuickSortNonRecursive_2d(arr, col)

End If

Else

ReDim i_arr(rl To ru)

rez = arr

If ascending Then

Call QuickSortNonRecursive_ia(arr, i_arr, col)

Else

Call QuickSortNonRecursive_id(arr, i_arr, col)

End If

For i = rl To ru

For j = nl To col - 1

arr(i, j) = rez(i_arr(i), j)

Next

For j = col + 1 To nu

arr(i, j) = rez(i_arr(i), j)

Next

Next

End If

Exit Sub

er1: If ascending Then

Call QuickSortNonRecursive_a(arr)

Else

Call QuickSortNonRecursive_d(arr)

End If


Exit Sub

er2: MsgBox "Не массив"

End Sub



'=========================================================================================================

Sub t()

Dim arr(1 To 4, 1 To 3), r

r = [a1:c4]

For i = 1 To 4

For j = 1 To 3

arr(i, j) = r(i, j)

Next

Next

Call sort_range(arr)

'[a1:c4] = arr

End Sub



'=========================================================================================================

Sub test()

Dim tm!, i&, r As Range

Dim arr(1 To 9, 1 To 3), r_arr

Application.ScreenUpdating = False

Set r = [a1:c9]

r_arr = r

For i = 1 To 9

For j = 1 To 3

arr(i, j) = r_arr(i, j)

Next

Next


tm = Timer

For i = 1 To 99

r.Sort Key1:=Range("C1"), Order1:=xlAscending, Header:= _

xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _

DataOption1:=xlSortNormal

'Call sort_range(arr)

r.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:= _

xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _

DataOption1:=xlSortNormal

Next

Debug.Print Timer - tm

Application.ScreenUpdating = True

End Sub



'=========================================================================================================

Public Sub QuickSortNonRecursive_d(SortArray())

Dim i As Long, j As Long, lb As Long, ub As Long

Dim stack() As QuickStack, stackpos As Long, ppos As Long, pivot As Variant, swp, maxstack&

On Error GoTo er

ReDim stack(1 To 16)

stackpos = 1


stack(1).Low = LBound(SortArray)

stack(1).High = UBound(SortArray)

Do

'Взять границы lb и ub текущего массива из стека.

lb = stack(stackpos).Low

ub = stack(stackpos).High

stackpos = stackpos - 1

Do

'Шаг 1. Разделение по элементу pivot

ppos = (lb + ub) \ 2

i = lb: j = ub: pivot = SortArray(ppos)

Do

While SortArray(i) > pivot: i = i + 1: Wend

While pivot > SortArray(j): j = j - 1: Wend

If i > j Then Exit Do

If i = j Then

i = i + 1

j = j - 1

Exit Do

End If

swp = SortArray(i): SortArray(i) = SortArray(j): SortArray(j) = swp

i = i + 1

j = j - 1

Loop 'While i <= j


'Сейчас указатель i указывает на начало правого подмассива,

'j - на конец левого lb ? j ? i ? ub.

'Возможен случай, когда указатель i или j выходит за границу массива

'Шаги 2, 3. Отправляем большую часть в стек и двигаем lb,ub


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

' Debug.Print maxstack

End Sub



'=========================================================================================================

Public Sub QuickSortNonRecursive_id(ByRef SortArray(), ByRef r() As Long, Optional ByVal col = 1)

Dim i As Long, j As Long, lb As Long, ub As Long

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)

ReDim stack(1 To 16)

' stackpos = 0


stack(1).Low = lb

stack(1).High = ub

'Шаг 1. Разделение по элементу pivot

ppos = (lb + ub) \ 2

i = lb: j = ub: pivot = SortArray(ppos, col)

Do

While SortArray(i, col) > pivot: r(i) = i: i = i + 1: Wend

While pivot > SortArray(j, col): r(j) = j: j = j - 1: Wend

If i > j Then Exit Do

If i = j Then

r(i) = i

i = i + 1

j = j - 1

Exit Do

End If

swp = SortArray(i, col): SortArray(i, col) = SortArray(j, col): SortArray(j, col) = swp

r(i) = j: r(j) = i

i = i + 1

j = j - 1

Loop 'While i <= j


'Сейчас указатель i указывает на начало правого подмассива,

'j - на конец левого lb ? j ? i ? ub.

'Возможен случай, когда указатель i или j выходит за границу массива

'Шаги 2, 3. Отправляем большую часть в стек и двигаем lb,ub


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

If lb >= ub Then Exit Sub

Do

'Взять границы lb и ub текущего массива из стека.

lb = stack(stackpos).Low

ub = stack(stackpos).High

stackpos = stackpos - 1

Do

'Шаг 1. Разделение по элементу pivot

ppos = (lb + ub) \ 2

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

r(i) = i

i = i + 1

j = j - 1

Exit Do

End If

swp = SortArray(i, col): SortArray(i, col) = SortArray(j, col): SortArray(j, col) = swp

swp = r(i): r(i) = r(j): r(j) = swp

i = i + 1

j = j - 1

Loop 'While i <= j


'Сейчас указатель i указывает на начало правого подмассива,

'j - на конец левого lb ? j ? i ? ub.

'Возможен случай, когда указатель i или j выходит за границу массива

'Шаги 2, 3. Отправляем большую часть в стек и двигаем lb,ub


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

' Debug.Print maxstack

End Sub



'=========================================================================================================

Public Sub QuickSortNonRecursive_2d(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 и ub текущего массива из стека.

lb = stack(stackpos).Low

ub = stack(stackpos).High

stackpos = stackpos - 1

Do

'Шаг 1. Разделение по элементу pivot

ppos = (lb + ub) \ 2

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

i = i + 1

j = j - 1

Exit Do

End If

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

i = i + 1

j = j - 1

Loop 'While i <= j


'Сейчас указатель i указывает на начало правого подмассива,

'j - на конец левого lb ? j ? i ? ub.

'Возможен случай, когда указатель i или j выходит за границу массива

'Шаги 2, 3. Отправляем большую часть в стек и двигаем lb,ub


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

' Debug.Print maxstack

End Sub





 
MyTetra Share v.0.55
Яндекс индекс цитирования