MyTetra Share Делитесь знаниями!
 Сортировка2 16.03.201923:43
Раздел: !Закладки - VBA

На листе:

 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.52