На листе:
|
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
