Can this QuickSort work?

[RB Smissaert]

Got the following QuickSort from Rd Edwards (posted on Planet Source Code as
well).
I think the has coded and tested in VB6 and says it works fine, but when I
run it in VBA it doesn't sort
properly.
Can't imagine that running it from VBA would make any difference, but have
otherwise no idea why it doesn't work.
Actually, I have now tested this in a VB6 .exe and exactly same output as in
VBA, so it doesn't sort properly there either.

Option Explicit
Private lbs() As Long, ubs() As Long ' qs v4 non-recursive stacks

Private Sub lngSwap4(lA() As Long, _
ByVal lbA As Long, _
ByVal ubA As Long, _
Optional ByVal bDescending As Boolean)

' This is my non-recursive Quick-Sort, and is very very fast!
Dim lo As Long
Dim hi As Long
Dim cnt As Long
Dim item As Long

lo = ((ubA - lbA) \ 8&) + 16& ' Allow for worst case senario

If lo > 0& Then
ReDim lbs(1& To lo) As Long
ReDim ubs(1& To lo) As Long
End If

'----==========----
If bDescending Then
'----==========----
Do
hi = ((ubA - lbA) \ 2&) + lbA ' Get pivot
item = lA(hi)
lA(hi) = lA(ubA) ' Grab current
lo = lbA
hi = ubA ' Set bounds

Do While (hi > lo) ' Storm right in
If (lA(lo) < item) Then
lA(hi) = lA(lo)
hi = hi - 1&
Do Until (hi = lo)
If (item < lA(hi)) Then
lA(lo) = lA(hi)
Exit Do
End If
hi = hi - 1&
Loop ' Found swaps or out of loop
If (lo = hi) Then
Exit Do
End If
End If
lo = lo + 1&
Loop

lA(hi) = item ' Re-assign current

If (lbA < lo - 1&) Then
If (ubA > lo + 1&) Then
cnt = cnt + 1&
lbs(cnt) = lo + 1&
End If
ubs(cnt) = ubA
ubA = lo - 1&
Else
If (ubA > lo + 1&) Then
lbA = lo + 1&
Else
If cnt = 0& Then
Exit Sub
End If
lbA = lbs(cnt)
ubA = ubs(cnt)
cnt = cnt - 1&
End If
End If
Loop
'----===========----
Else '-Blizzard v4 ©Rd-
'----===========----
Do
hi = ((ubA - lbA) \ 2&) + lbA ' Get pivot
item = lA(hi)
lA(hi) = lA(ubA) ' Grab current
lo = lbA
hi = ubA ' Set bounds

Do While (hi > lo) ' Storm right in
If (lA(lo) > item) Then
lA(hi) = lA(lo)
hi = hi - 1&
Do Until (hi = lo)
If (item > lA(hi)) Then
lA(lo) = lA(hi)
Exit Do
End If
hi = hi - 1&
Loop ' Found swaps or out of loop
If (lo = hi) Then
Exit Do
End If
End If
lo = lo + 1&
Loop

lA(hi) = item ' Re-assign current

If (lbA < lo - 1&) Then
If (ubA > lo + 1&) Then
cnt = cnt + 1&
lbs(cnt) = lo + 1&
End If
ubs(cnt) = ubA
ubA = lo - 1&
Else
If (ubA > lo + 1&) Then
lbA = lo + 1&
Else
If cnt = 0& Then
Exit Sub
End If
lbA = lbs(cnt)
ubA = ubs(cnt)
cnt = cnt - 1&
'----===========----
End If
End If
Loop
End If
'----===========----

End Sub


When I test like this:

Sub test()

Dim i As Long
Dim arr(1 To 10) As Long

For i = 1 To 10
arr(i) = 11 - i
Debug.Print arr(i)
Next

Debug.Print "--------------"

lngSwap4 arr, 1, 10

For i = 1 To 10
Debug.Print arr(i)
Next

End Sub

I consistently get the following output:

10
9
8
7
6
5
4
3
2
1
--------------
1
2
5
4
3
6
7
8
9
10


Has anybody used this code and made it to work?


RBS

[Bob Phillips]

Bart,

Have you tried it in VB, and does it work?

It seems to sort fine, then does one more loop where it swaps two items that
are in order. This mod seems to work

Private Sub lngSwap4(lA() As Long, _
ByVal lbA As Long, _
ByVal ubA As Long, _
Optional ByVal bDescending As Boolean)

' This is my non-recursive Quick-Sort, and is very very fast!
Dim lo As Long
Dim hi As Long
Dim cnt As Long
Dim item As Long

lo = ((ubA - lbA) \ 8&) + 16& ' Allow for worst case senario

If lo > 0& Then
ReDim lbs(1& To lo) As Long
ReDim ubs(1& To lo) As Long
End If

'----==========----
If bDescending Then
'----==========----
Do
hi = ((ubA - lbA) \ 2&) + lbA ' Get pivot
item = lA(hi)
lA(hi) = lA(ubA) ' Grab current
lo = lbA
hi = ubA ' Set bounds

Do While (hi > lo) ' Storm right in
If (lA(lo) < item) Then
lA(hi) = lA(lo)
hi = hi - 1&
Do Until (hi = lo)
If (item < lA(hi)) Then
lA(lo) = lA(hi)
Exit Do
End If
hi = hi - 1&
Loop ' Found swaps or out of loop
If (lo = hi) Then
Exit Do
End If
End If
lo = lo + 1&
Loop

lA(hi) = item ' Re-assign current

If (lbA < lo - 1&) Then
If (ubA > lo + 1&) Then
cnt = cnt + 1&
lbs(cnt) = lo + 1&
End If
ubs(cnt) = ubA
ubA = lo - 1&
Else
If (ubA > lo + 1&) Then
lbA = lo + 1&
Else
If cnt = 0& Then
Exit Sub
End If
lbA = lbs(cnt)
ubA = ubs(cnt)
cnt = cnt - 1&
End If
End If
Loop While cnt <> 0
'----===========----
Else '-Blizzard v4 ©Rd-
'----===========----
Do
hi = ((ubA - lbA) \ 2&) + lbA ' Get pivot
item = lA(hi)
lA(hi) = lA(ubA) ' Grab current
lo = lbA
hi = ubA ' Set bounds

Do While (hi > lo) ' Storm right in
If (lA(lo) > item) Then
lA(hi) = lA(lo)
hi = hi - 1&
Do Until (hi = lo)
If (item > lA(hi)) Then
lA(lo) = lA(hi)
Exit Do
End If
hi = hi - 1&
Loop ' Found swaps or out of loop
If (lo = hi) Then
Exit Do
End If
End If
lo = lo + 1&
Loop

lA(hi) = item ' Re-assign current

If (lbA < lo - 1&) Then
If (ubA > lo + 1&) Then
cnt = cnt + 1&
lbs(cnt) = lo + 1&
End If
ubs(cnt) = ubA
ubA = lo - 1&
Else
If (ubA > lo + 1&) Then
lbA = lo + 1&
Else
If cnt = 0& Then
Exit Sub
End If
lbA = lbs(cnt)
ubA = ubs(cnt)
cnt = cnt - 1&
'----===========----
End If
End If
Loop While cnt <> 0
End If
'----===========----

End Sub

--
HTH

Bob Phillips

(replace somewhere in email address with gmail if mailing direct)

"RB Smissaert" <bartsmissaert@blueyonder.co.uk> wrote in message
news:OjyY6hDmGHA.856@TK2MSFTNGP03.phx.gbl...
> Got the following QuickSort from Rd Edwards (posted on Planet Source Code
as
> well).
> I think the has coded and tested in VB6 and says it works fine, but when I
> run it in VBA it doesn't sort
> properly.
> Can't imagine that running it from VBA would make any difference, but have
> otherwise no idea why it doesn't work.
> Actually, I have now tested this in a VB6 .exe and exactly same output as
in
> VBA, so it doesn't sort properly there either.
>
> Option Explicit
> Private lbs() As Long, ubs() As Long ' qs v4 non-recursive stacks
>
> Private Sub lngSwap4(lA() As Long, _
> ByVal lbA As Long, _
> ByVal ubA As Long, _
> Optional ByVal bDescending As Boolean)
>
> ' This is my non-recursive Quick-Sort, and is very very fast!
> Dim lo As Long
> Dim hi As Long
> Dim cnt As Long
> Dim item As Long
>
> lo = ((ubA - lbA) \ 8&) + 16& ' Allow for worst case senario
>
> If lo > 0& Then
> ReDim lbs(1& To lo) As Long
> ReDim ubs(1& To lo) As Long
> End If
>
> '----==========----
> If bDescending Then
> '----==========----
> Do
> hi = ((ubA - lbA) \ 2&) + lbA ' Get pivot
> item = lA(hi)
> lA(hi) = lA(ubA) ' Grab current
> lo = lbA
> hi = ubA ' Set bounds
>
> Do While (hi > lo) ' Storm right in
> If (lA(lo) < item) Then
> lA(hi) = lA(lo)
> hi = hi - 1&
> Do Until (hi = lo)
> If (item < lA(hi)) Then
> lA(lo) = lA(hi)
> Exit Do
> End If
> hi = hi - 1&
> Loop ' Found swaps or out of loop
> If (lo = hi) Then
> Exit Do
> End If
> End If
> lo = lo + 1&
> Loop
>
> lA(hi) = item ' Re-assign current
>
> If (lbA < lo - 1&) Then
> If (ubA > lo + 1&) Then
> cnt = cnt + 1&
> lbs(cnt) = lo + 1&
> End If
> ubs(cnt) = ubA
> ubA = lo - 1&
> Else
> If (ubA > lo + 1&) Then
> lbA = lo + 1&
> Else
> If cnt = 0& Then
> Exit Sub
> End If
> lbA = lbs(cnt)
> ubA = ubs(cnt)
> cnt = cnt - 1&
> End If
> End If
> Loop
> '----===========----
> Else '-Blizzard v4 ©Rd-
> '----===========----
> Do
> hi = ((ubA - lbA) \ 2&) + lbA ' Get pivot
> item = lA(hi)
> lA(hi) = lA(ubA) ' Grab current
> lo = lbA
> hi = ubA ' Set bounds
>
> Do While (hi > lo) ' Storm right in
> If (lA(lo) > item) Then
> lA(hi) = lA(lo)
> hi = hi - 1&
> Do Until (hi = lo)
> If (item > lA(hi)) Then
> lA(lo) = lA(hi)
> Exit Do
> End If
> hi = hi - 1&
> Loop ' Found swaps or out of loop
> If (lo = hi) Then
> Exit Do
> End If
> End If
> lo = lo + 1&
> Loop
>
> lA(hi) = item ' Re-assign current
>
> If (lbA < lo - 1&) Then
> If (ubA > lo + 1&) Then
> cnt = cnt + 1&
> lbs(cnt) = lo + 1&
> End If
> ubs(cnt) = ubA
> ubA = lo - 1&
> Else
> If (ubA > lo + 1&) Then
> lbA = lo + 1&
> Else
> If cnt = 0& Then
> Exit Sub
> End If
> lbA = lbs(cnt)
> ubA = ubs(cnt)
> cnt = cnt - 1&
> '----===========----
> End If
> End If
> Loop
> End If
> '----===========----
>
> End Sub
>
>
> When I test like this:
>
> Sub test()
>
> Dim i As Long
> Dim arr(1 To 10) As Long
>
> For i = 1 To 10
> arr(i) = 11 - i
> Debug.Print arr(i)
> Next
>
> Debug.Print "--------------"
>
> lngSwap4 arr, 1, 10
>
> For i = 1 To 10
> Debug.Print arr(i)
> Next
>
> End Sub
>
> I consistently get the following output:
>
> 10
> 9
> 8
> 7
> 6
> 5
> 4
> 3
> 2
> 1
> --------------
> 1
> 2
> 5
> 4
> 3
> 6
> 7
> 8
> 9
> 10
>
>
> Has anybody used this code and made it to work?
>
>
> RBS
>

[RB Smissaert]

Thanks, will have a look.
I found this solved it. Also solves an error when
the array is lbound 1 and ubound 4:

Private Sub lngSwap4(lA() As Long, _
ByVal lbA As Long, _
ByVal ubA As Long, _
Optional ByVal bDescending As Boolean)

' This is my non-recursive Quick-Sort, and is very very fast!
Dim lo As Long
Dim hi As Long
Dim cnt As Long
Dim item As Long

lo = ((ubA - lbA) \ 8&) + 16& ' Allow for worst case senario

If lo > 0& Then
ReDim lbs(1& To lo) As Long
ReDim ubs(1& To lo) As Long
End If

'----==========----
If bDescending Then
'----==========----
Do
hi = ((ubA - lbA) \ 2&) + lbA ' Get pivot
item = lA(hi)
lA(hi) = lA(ubA) ' Grab current
lo = lbA
hi = ubA ' Set bounds

Do While (hi > lo) ' Storm right in
If (lA(lo) < item) Then
lA(hi) = lA(lo)
hi = hi - 1&
Do Until (hi = lo)
If (item < lA(hi)) Then
lA(lo) = lA(hi)
Exit Do
End If
hi = hi - 1&
Loop ' Found swaps or out of loop
If (lo = hi) Then
Exit Do
End If
End If
lo = lo + 1&
Loop

lA(hi) = item ' Re-assign current

If (lbA < lo - 1&) Then
If (ubA > lo + 1&) Then
cnt = cnt + 1&
lbs(cnt) = lo + 1&
End If

'added code
'----------
If cnt < LBound(lA) Then
cnt = LBound(lA)
End If

ubs(cnt) = ubA
ubA = lo - 1&
Else
If (ubA > lo + 1&) Then
lbA = lo + 1&

Else
If cnt = 0& Then
Exit Sub
End If
lbA = lbs(cnt)

ubA = ubs(cnt)
cnt = cnt - 1&
End If
End If
Loop
'----===========----
Else '-Blizzard v4 ©Rd-
'----===========----
Do
hi = ((ubA - lbA) \ 2&) + lbA ' Get pivot
item = lA(hi)
lA(hi) = lA(ubA) ' Grab current
lo = lbA
hi = ubA ' Set bounds

Do While (hi > lo) ' Storm right in
If (lA(lo) > item) Then
lA(hi) = lA(lo)
hi = hi - 1&
Do Until (hi = lo)
If (item > lA(hi)) Then
lA(lo) = lA(hi)
Exit Do
End If
hi = hi - 1&
Loop ' Found swaps or out of loop
If (lo = hi) Then
Exit Do
End If
End If
lo = lo + 1&
Loop

lA(hi) = item ' Re-assign current

If (lbA < lo - 1&) Then
If (ubA > lo + 1&) Then
cnt = cnt + 1&
lbs(cnt) = lo + 1&
End If

'added code
'----------
If cnt < LBound(lA) Then
cnt = LBound(lA)
End If

ubs(cnt) = ubA
ubA = lo - 1&
Else
If (ubA > lo + 1&) Then
lbA = lo + 1&

Else
If cnt = 0& Then
Exit Sub
End If

ubA = ubs(cnt)
cnt = cnt - 1&
'----===========----
End If
End If
Loop
End If
'----===========----

End Sub


RBS



"Bob Phillips" <bob.NGs@somewhere.com> wrote in message
news:%23F7pNAFmGHA.464@TK2MSFTNGP05.phx.gbl...
> Bart,
>
> Have you tried it in VB, and does it work?
>
> It seems to sort fine, then does one more loop where it swaps two items
> that
> are in order. This mod seems to work
>
> Private Sub lngSwap4(lA() As Long, _
> ByVal lbA As Long, _
> ByVal ubA As Long, _
> Optional ByVal bDescending As Boolean)
>
> ' This is my non-recursive Quick-Sort, and is very very fast!
> Dim lo As Long
> Dim hi As Long
> Dim cnt As Long
> Dim item As Long
>
> lo = ((ubA - lbA) \ 8&) + 16& ' Allow for worst case senario
>
> If lo > 0& Then
> ReDim lbs(1& To lo) As Long
> ReDim ubs(1& To lo) As Long
> End If
>
> '----==========----
> If bDescending Then
> '----==========----
> Do
> hi = ((ubA - lbA) \ 2&) + lbA ' Get pivot
> item = lA(hi)
> lA(hi) = lA(ubA) ' Grab current
> lo = lbA
> hi = ubA ' Set bounds
>
> Do While (hi > lo) ' Storm right in
> If (lA(lo) < item) Then
> lA(hi) = lA(lo)
> hi = hi - 1&
> Do Until (hi = lo)
> If (item < lA(hi)) Then
> lA(lo) = lA(hi)
> Exit Do
> End If
> hi = hi - 1&
> Loop ' Found swaps or out of loop
> If (lo = hi) Then
> Exit Do
> End If
> End If
> lo = lo + 1&
> Loop
>
> lA(hi) = item ' Re-assign current
>
> If (lbA < lo - 1&) Then
> If (ubA > lo + 1&) Then
> cnt = cnt + 1&
> lbs(cnt) = lo + 1&
> End If
> ubs(cnt) = ubA
> ubA = lo - 1&
> Else
> If (ubA > lo + 1&) Then
> lbA = lo + 1&
> Else
> If cnt = 0& Then
> Exit Sub
> End If
> lbA = lbs(cnt)
> ubA = ubs(cnt)
> cnt = cnt - 1&
> End If
> End If
> Loop While cnt <> 0
> '----===========----
> Else '-Blizzard v4 ©Rd-
> '----===========----
> Do
> hi = ((ubA - lbA) \ 2&) + lbA ' Get pivot
> item = lA(hi)
> lA(hi) = lA(ubA) ' Grab current
> lo = lbA
> hi = ubA ' Set bounds
>
> Do While (hi > lo) ' Storm right in
> If (lA(lo) > item) Then
> lA(hi) = lA(lo)
> hi = hi - 1&
> Do Until (hi = lo)
> If (item > lA(hi)) Then
> lA(lo) = lA(hi)
> Exit Do
> End If
> hi = hi - 1&
> Loop ' Found swaps or out of loop
> If (lo = hi) Then
> Exit Do
> End If
> End If
> lo = lo + 1&
> Loop
>
> lA(hi) = item ' Re-assign current
>
> If (lbA < lo - 1&) Then
> If (ubA > lo + 1&) Then
> cnt = cnt + 1&
> lbs(cnt) = lo + 1&
> End If
> ubs(cnt) = ubA
> ubA = lo - 1&
> Else
> If (ubA > lo + 1&) Then
> lbA = lo + 1&
> Else
> If cnt = 0& Then
> Exit Sub
> End If
> lbA = lbs(cnt)
> ubA = ubs(cnt)
> cnt = cnt - 1&
> '----===========----
> End If
> End If
> Loop While cnt <> 0
> End If
> '----===========----
>
> End Sub
>
> --
> HTH
>
> Bob Phillips
>
> (replace somewhere in email address with gmail if mailing direct)
>
> "RB Smissaert" <bartsmissaert@blueyonder.co.uk> wrote in message
> news:OjyY6hDmGHA.856@TK2MSFTNGP03.phx.gbl...
>> Got the following QuickSort from Rd Edwards (posted on Planet Source Code
> as
>> well).
>> I think the has coded and tested in VB6 and says it works fine, but when
>> I
>> run it in VBA it doesn't sort
>> properly.
>> Can't imagine that running it from VBA would make any difference, but
>> have
>> otherwise no idea why it doesn't work.
>> Actually, I have now tested this in a VB6 .exe and exactly same output as
> in
>> VBA, so it doesn't sort properly there either.
>>
>> Option Explicit
>> Private lbs() As Long, ubs() As Long ' qs v4 non-recursive stacks
>>
>> Private Sub lngSwap4(lA() As Long, _
>> ByVal lbA As Long, _
>> ByVal ubA As Long, _
>> Optional ByVal bDescending As Boolean)
>>
>> ' This is my non-recursive Quick-Sort, and is very very fast!
>> Dim lo As Long
>> Dim hi As Long
>> Dim cnt As Long
>> Dim item As Long
>>
>> lo = ((ubA - lbA) \ 8&) + 16& ' Allow for worst case senario
>>
>> If lo > 0& Then
>> ReDim lbs(1& To lo) As Long
>> ReDim ubs(1& To lo) As Long
>> End If
>>
>> '----==========----
>> If bDescending Then
>> '----==========----
>> Do
>> hi = ((ubA - lbA) \ 2&) + lbA ' Get pivot
>> item = lA(hi)
>> lA(hi) = lA(ubA) ' Grab current
>> lo = lbA
>> hi = ubA ' Set bounds
>>
>> Do While (hi > lo) ' Storm right in
>> If (lA(lo) < item) Then
>> lA(hi) = lA(lo)
>> hi = hi - 1&
>> Do Until (hi = lo)
>> If (item < lA(hi)) Then
>> lA(lo) = lA(hi)
>> Exit Do
>> End If
>> hi = hi - 1&
>> Loop ' Found swaps or out of loop
>> If (lo = hi) Then
>> Exit Do
>> End If
>> End If
>> lo = lo + 1&
>> Loop
>>
>> lA(hi) = item ' Re-assign current
>>
>> If (lbA < lo - 1&) Then
>> If (ubA > lo + 1&) Then
>> cnt = cnt + 1&
>> lbs(cnt) = lo + 1&
>> End If
>> ubs(cnt) = ubA
>> ubA = lo - 1&
>> Else
>> If (ubA > lo + 1&) Then
>> lbA = lo + 1&
>> Else
>> If cnt = 0& Then
>> Exit Sub
>> End If
>> lbA = lbs(cnt)
>> ubA = ubs(cnt)
>> cnt = cnt - 1&
>> End If
>> End If
>> Loop
>> '----===========----
>> Else '-Blizzard v4 ©Rd-
>> '----===========----
>> Do
>> hi = ((ubA - lbA) \ 2&) + lbA ' Get pivot
>> item = lA(hi)
>> lA(hi) = lA(ubA) ' Grab current
>> lo = lbA
>> hi = ubA ' Set bounds
>>
>> Do While (hi > lo) ' Storm right in
>> If (lA(lo) > item) Then
>> lA(hi) = lA(lo)
>> hi = hi - 1&
>> Do Until (hi = lo)
>> If (item > lA(hi)) Then
>> lA(lo) = lA(hi)
>> Exit Do
>> End If
>> hi = hi - 1&
>> Loop ' Found swaps or out of loop
>> If (lo = hi) Then
>> Exit Do
>> End If
>> End If
>> lo = lo + 1&
>> Loop
>>
>> lA(hi) = item ' Re-assign current
>>
>> If (lbA < lo - 1&) Then
>> If (ubA > lo + 1&) Then
>> cnt = cnt + 1&
>> lbs(cnt) = lo + 1&
>> End If
>> ubs(cnt) = ubA
>> ubA = lo - 1&
>> Else
>> If (ubA > lo + 1&) Then
>> lbA = lo + 1&
>> Else
>> If cnt = 0& Then
>> Exit Sub
>> End If
>> lbA = lbs(cnt)
>> ubA = ubs(cnt)
>> cnt = cnt - 1&
>> '----===========----
>> End If
>> End If
>> Loop
>> End If
>> '----===========----
>>
>> End Sub
>>
>>
>> When I test like this:
>>
>> Sub test()
>>
>> Dim i As Long
>> Dim arr(1 To 10) As Long
>>
>> For i = 1 To 10
>> arr(i) = 11 - i
>> Debug.Print arr(i)
>> Next
>>
>> Debug.Print "--------------"
>>
>> lngSwap4 arr, 1, 10
>>
>> For i = 1 To 10
>> Debug.Print arr(i)
>> Next
>>
>> End Sub
>>
>> I consistently get the following output:
>>
>> 10
>> 9
>> 8
>> 7
>> 6
>> 5
>> 4
>> 3
>> 2
>> 1
>> --------------
>> 1
>> 2
>> 5
>> 4
>> 3
>> 6
>> 7
>> 8
>> 9
>> 10
>>
>>
>> Has anybody used this code and made it to work?
>>
>>
>> RBS
>>
>
>

[RB Smissaert]

Yes, tried in VB and exactly same faults.

RBS

"Bob Phillips" <bob.NGs@somewhere.com> wrote in message
news:%23F7pNAFmGHA.464@TK2MSFTNGP05.phx.gbl...
> Bart,
>
> Have you tried it in VB, and does it work?
>
> It seems to sort fine, then does one more loop where it swaps two items
> that
> are in order. This mod seems to work
>
> Private Sub lngSwap4(lA() As Long, _
> ByVal lbA As Long, _
> ByVal ubA As Long, _
> Optional ByVal bDescending As Boolean)
>
> ' This is my non-recursive Quick-Sort, and is very very fast!
> Dim lo As Long
> Dim hi As Long
> Dim cnt As Long
> Dim item As Long
>
> lo = ((ubA - lbA) \ 8&) + 16& ' Allow for worst case senario
>
> If lo > 0& Then
> ReDim lbs(1& To lo) As Long
> ReDim ubs(1& To lo) As Long
> End If
>
> '----==========----
> If bDescending Then
> '----==========----
> Do
> hi = ((ubA - lbA) \ 2&) + lbA ' Get pivot
> item = lA(hi)
> lA(hi) = lA(ubA) ' Grab current
> lo = lbA
> hi = ubA ' Set bounds
>
> Do While (hi > lo) ' Storm right in
> If (lA(lo) < item) Then
> lA(hi) = lA(lo)
> hi = hi - 1&
> Do Until (hi = lo)
> If (item < lA(hi)) Then
> lA(lo) = lA(hi)
> Exit Do
> End If
> hi = hi - 1&
> Loop ' Found swaps or out of loop
> If (lo = hi) Then
> Exit Do
> End If
> End If
> lo = lo + 1&
> Loop
>
> lA(hi) = item ' Re-assign current
>
> If (lbA < lo - 1&) Then
> If (ubA > lo + 1&) Then
> cnt = cnt + 1&
> lbs(cnt) = lo + 1&
> End If
> ubs(cnt) = ubA
> ubA = lo - 1&
> Else
> If (ubA > lo + 1&) Then
> lbA = lo + 1&
> Else
> If cnt = 0& Then
> Exit Sub
> End If
> lbA = lbs(cnt)
> ubA = ubs(cnt)
> cnt = cnt - 1&
> End If
> End If
> Loop While cnt <> 0
> '----===========----
> Else '-Blizzard v4 ©Rd-
> '----===========----
> Do
> hi = ((ubA - lbA) \ 2&) + lbA ' Get pivot
> item = lA(hi)
> lA(hi) = lA(ubA) ' Grab current
> lo = lbA
> hi = ubA ' Set bounds
>
> Do While (hi > lo) ' Storm right in
> If (lA(lo) > item) Then
> lA(hi) = lA(lo)
> hi = hi - 1&
> Do Until (hi = lo)
> If (item > lA(hi)) Then
> lA(lo) = lA(hi)
> Exit Do
> End If
> hi = hi - 1&
> Loop ' Found swaps or out of loop
> If (lo = hi) Then
> Exit Do
> End If
> End If
> lo = lo + 1&
> Loop
>
> lA(hi) = item ' Re-assign current
>
> If (lbA < lo - 1&) Then
> If (ubA > lo + 1&) Then
> cnt = cnt + 1&
> lbs(cnt) = lo + 1&
> End If
> ubs(cnt) = ubA
> ubA = lo - 1&
> Else
> If (ubA > lo + 1&) Then
> lbA = lo + 1&
> Else
> If cnt = 0& Then
> Exit Sub
> End If
> lbA = lbs(cnt)
> ubA = ubs(cnt)
> cnt = cnt - 1&
> '----===========----
> End If
> End If
> Loop While cnt <> 0
> End If
> '----===========----
>
> End Sub
>
> --
> HTH
>
> Bob Phillips
>
> (replace somewhere in email address with gmail if mailing direct)
>
> "RB Smissaert" <bartsmissaert@blueyonder.co.uk> wrote in message
> news:OjyY6hDmGHA.856@TK2MSFTNGP03.phx.gbl...
>> Got the following QuickSort from Rd Edwards (posted on Planet Source Code
> as
>> well).
>> I think the has coded and tested in VB6 and says it works fine, but when
>> I
>> run it in VBA it doesn't sort
>> properly.
>> Can't imagine that running it from VBA would make any difference, but
>> have
>> otherwise no idea why it doesn't work.
>> Actually, I have now tested this in a VB6 .exe and exactly same output as
> in
>> VBA, so it doesn't sort properly there either.
>>
>> Option Explicit
>> Private lbs() As Long, ubs() As Long ' qs v4 non-recursive stacks
>>
>> Private Sub lngSwap4(lA() As Long, _
>> ByVal lbA As Long, _
>> ByVal ubA As Long, _
>> Optional ByVal bDescending As Boolean)
>>
>> ' This is my non-recursive Quick-Sort, and is very very fast!
>> Dim lo As Long
>> Dim hi As Long
>> Dim cnt As Long
>> Dim item As Long
>>
>> lo = ((ubA - lbA) \ 8&) + 16& ' Allow for worst case senario
>>
>> If lo > 0& Then
>> ReDim lbs(1& To lo) As Long
>> ReDim ubs(1& To lo) As Long
>> End If
>>
>> '----==========----
>> If bDescending Then
>> '----==========----
>> Do
>> hi = ((ubA - lbA) \ 2&) + lbA ' Get pivot
>> item = lA(hi)
>> lA(hi) = lA(ubA) ' Grab current
>> lo = lbA
>> hi = ubA ' Set bounds
>>
>> Do While (hi > lo) ' Storm right in
>> If (lA(lo) < item) Then
>> lA(hi) = lA(lo)
>> hi = hi - 1&
>> Do Until (hi = lo)
>> If (item < lA(hi)) Then
>> lA(lo) = lA(hi)
>> Exit Do
>> End If
>> hi = hi - 1&
>> Loop ' Found swaps or out of loop
>> If (lo = hi) Then
>> Exit Do
>> End If
>> End If
>> lo = lo + 1&
>> Loop
>>
>> lA(hi) = item ' Re-assign current
>>
>> If (lbA < lo - 1&) Then
>> If (ubA > lo + 1&) Then
>> cnt = cnt + 1&
>> lbs(cnt) = lo + 1&
>> End If
>> ubs(cnt) = ubA
>> ubA = lo - 1&
>> Else
>> If (ubA > lo + 1&) Then
>> lbA = lo + 1&
>> Else
>> If cnt = 0& Then
>> Exit Sub
>> End If
>> lbA = lbs(cnt)
>> ubA = ubs(cnt)
>> cnt = cnt - 1&
>> End If
>> End If
>> Loop
>> '----===========----
>> Else '-Blizzard v4 ©Rd-
>> '----===========----
>> Do
>> hi = ((ubA - lbA) \ 2&) + lbA ' Get pivot
>> item = lA(hi)
>> lA(hi) = lA(ubA) ' Grab current
>> lo = lbA
>> hi = ubA ' Set bounds
>>
>> Do While (hi > lo) ' Storm right in
>> If (lA(lo) > item) Then
>> lA(hi) = lA(lo)
>> hi = hi - 1&
>> Do Until (hi = lo)
>> If (item > lA(hi)) Then
>> lA(lo) = lA(hi)
>> Exit Do
>> End If
>> hi = hi - 1&
>> Loop ' Found swaps or out of loop
>> If (lo = hi) Then
>> Exit Do
>> End If
>> End If
>> lo = lo + 1&
>> Loop
>>
>> lA(hi) = item ' Re-assign current
>>
>> If (lbA < lo - 1&) Then
>> If (ubA > lo + 1&) Then
>> cnt = cnt + 1&
>> lbs(cnt) = lo + 1&
>> End If
>> ubs(cnt) = ubA
>> ubA = lo - 1&
>> Else
>> If (ubA > lo + 1&) Then
>> lbA = lo + 1&
>> Else
>> If cnt = 0& Then
>> Exit Sub
>> End If
>> lbA = lbs(cnt)
>> ubA = ubs(cnt)
>> cnt = cnt - 1&
>> '----===========----
>> End If
>> End If
>> Loop
>> End If
>> '----===========----
>>
>> End Sub
>>
>>
>> When I test like this:
>>
>> Sub test()
>>
>> Dim i As Long
>> Dim arr(1 To 10) As Long
>>
>> For i = 1 To 10
>> arr(i) = 11 - i
>> Debug.Print arr(i)
>> Next
>>
>> Debug.Print "--------------"
>>
>> lngSwap4 arr, 1, 10
>>
>> For i = 1 To 10
>> Debug.Print arr(i)
>> Next
>>
>> End Sub
>>
>> I consistently get the following output:
>>
>> 10
>> 9
>> 8
>> 7
>> 6
>> 5
>> 4
>> 3
>> 2
>> 1
>> --------------
>> 1
>> 2
>> 5
>> 4
>> 3
>> 6
>> 7
>> 8
>> 9
>> 10
>>
>>
>> Has anybody used this code and made it to work?
>>
>>
>> RBS
>>
>
>

[Bob Phillips]

I am not surprised, as it didn't seem to use anything particularly VBA.

Bob

"RB Smissaert" <bartsmissaert@blueyonder.co.uk> wrote in message
news:u%23Ma8MFmGHA.4772@TK2MSFTNGP04.phx.gbl...
> Yes, tried in VB and exactly same faults.
>
> RBS
>
> "Bob Phillips" <bob.NGs@somewhere.com> wrote in message
> news:%23F7pNAFmGHA.464@TK2MSFTNGP05.phx.gbl...
> > Bart,
> >
> > Have you tried it in VB, and does it work?
> >
> > It seems to sort fine, then does one more loop where it swaps two items
> > that
> > are in order. This mod seems to work
> >
> > Private Sub lngSwap4(lA() As Long, _
> > ByVal lbA As Long, _
> > ByVal ubA As Long, _
> > Optional ByVal bDescending As Boolean)
> >
> > ' This is my non-recursive Quick-Sort, and is very very fast!
> > Dim lo As Long
> > Dim hi As Long
> > Dim cnt As Long
> > Dim item As Long
> >
> > lo = ((ubA - lbA) \ 8&) + 16& ' Allow for worst case senario
> >
> > If lo > 0& Then
> > ReDim lbs(1& To lo) As Long
> > ReDim ubs(1& To lo) As Long
> > End If
> >
> > '----==========----
> > If bDescending Then
> > '----==========----
> > Do
> > hi = ((ubA - lbA) \ 2&) + lbA ' Get pivot
> > item = lA(hi)
> > lA(hi) = lA(ubA) ' Grab current
> > lo = lbA
> > hi = ubA ' Set bounds
> >
> > Do While (hi > lo) ' Storm right in
> > If (lA(lo) < item) Then
> > lA(hi) = lA(lo)
> > hi = hi - 1&
> > Do Until (hi = lo)
> > If (item < lA(hi)) Then
> > lA(lo) = lA(hi)
> > Exit Do
> > End If
> > hi = hi - 1&
> > Loop ' Found swaps or out of loop
> > If (lo = hi) Then
> > Exit Do
> > End If
> > End If
> > lo = lo + 1&
> > Loop
> >
> > lA(hi) = item ' Re-assign current
> >
> > If (lbA < lo - 1&) Then
> > If (ubA > lo + 1&) Then
> > cnt = cnt + 1&
> > lbs(cnt) = lo + 1&
> > End If
> > ubs(cnt) = ubA
> > ubA = lo - 1&
> > Else
> > If (ubA > lo + 1&) Then
> > lbA = lo + 1&
> > Else
> > If cnt = 0& Then
> > Exit Sub
> > End If
> > lbA = lbs(cnt)
> > ubA = ubs(cnt)
> > cnt = cnt - 1&
> > End If
> > End If
> > Loop While cnt <> 0
> > '----===========----
> > Else '-Blizzard v4 ©Rd-
> > '----===========----
> > Do
> > hi = ((ubA - lbA) \ 2&) + lbA ' Get pivot
> > item = lA(hi)
> > lA(hi) = lA(ubA) ' Grab current
> > lo = lbA
> > hi = ubA ' Set bounds
> >
> > Do While (hi > lo) ' Storm right in
> > If (lA(lo) > item) Then
> > lA(hi) = lA(lo)
> > hi = hi - 1&
> > Do Until (hi = lo)
> > If (item > lA(hi)) Then
> > lA(lo) = lA(hi)
> > Exit Do
> > End If
> > hi = hi - 1&
> > Loop ' Found swaps or out of loop
> > If (lo = hi) Then
> > Exit Do
> > End If
> > End If
> > lo = lo + 1&
> > Loop
> >
> > lA(hi) = item ' Re-assign current
> >
> > If (lbA < lo - 1&) Then
> > If (ubA > lo + 1&) Then
> > cnt = cnt + 1&
> > lbs(cnt) = lo + 1&
> > End If
> > ubs(cnt) = ubA
> > ubA = lo - 1&
> > Else
> > If (ubA > lo + 1&) Then
> > lbA = lo + 1&
> > Else
> > If cnt = 0& Then
> > Exit Sub
> > End If
> > lbA = lbs(cnt)
> > ubA = ubs(cnt)
> > cnt = cnt - 1&
> > '----===========----
> > End If
> > End If
> > Loop While cnt <> 0
> > End If
> > '----===========----
> >
> > End Sub
> >
> > --
> > HTH
> >
> > Bob Phillips
> >
> > (replace somewhere in email address with gmail if mailing direct)
> >
> > "RB Smissaert" <bartsmissaert@blueyonder.co.uk> wrote in message
> > news:OjyY6hDmGHA.856@TK2MSFTNGP03.phx.gbl...
> >> Got the following QuickSort from Rd Edwards (posted on Planet Source
Code
> > as
> >> well).
> >> I think the has coded and tested in VB6 and says it works fine, but
when
> >> I
> >> run it in VBA it doesn't sort
> >> properly.
> >> Can't imagine that running it from VBA would make any difference, but
> >> have
> >> otherwise no idea why it doesn't work.
> >> Actually, I have now tested this in a VB6 .exe and exactly same output
as
> > in
> >> VBA, so it doesn't sort properly there either.
> >>
> >> Option Explicit
> >> Private lbs() As Long, ubs() As Long ' qs v4 non-recursive stacks
> >>
> >> Private Sub lngSwap4(lA() As Long, _
> >> ByVal lbA As Long, _
> >> ByVal ubA As Long, _
> >> Optional ByVal bDescending As Boolean)
> >>
> >> ' This is my non-recursive Quick-Sort, and is very very fast!
> >> Dim lo As Long
> >> Dim hi As Long
> >> Dim cnt As Long
> >> Dim item As Long
> >>
> >> lo = ((ubA - lbA) \ 8&) + 16& ' Allow for worst case senario
> >>
> >> If lo > 0& Then
> >> ReDim lbs(1& To lo) As Long
> >> ReDim ubs(1& To lo) As Long
> >> End If
> >>
> >> '----==========----
> >> If bDescending Then
> >> '----==========----
> >> Do
> >> hi = ((ubA - lbA) \ 2&) + lbA ' Get pivot
> >> item = lA(hi)
> >> lA(hi) = lA(ubA) ' Grab current
> >> lo = lbA
> >> hi = ubA ' Set bounds
> >>
> >> Do While (hi > lo) ' Storm right in
> >> If (lA(lo) < item) Then
> >> lA(hi) = lA(lo)
> >> hi = hi - 1&
> >> Do Until (hi = lo)
> >> If (item < lA(hi)) Then
> >> lA(lo) = lA(hi)
> >> Exit Do
> >> End If
> >> hi = hi - 1&
> >> Loop ' Found swaps or out of loop
> >> If (lo = hi) Then
> >> Exit Do
> >> End If
> >> End If
> >> lo = lo + 1&
> >> Loop
> >>
> >> lA(hi) = item ' Re-assign current
> >>
> >> If (lbA < lo - 1&) Then
> >> If (ubA > lo + 1&) Then
> >> cnt = cnt + 1&
> >> lbs(cnt) = lo + 1&
> >> End If
> >> ubs(cnt) = ubA
> >> ubA = lo - 1&
> >> Else
> >> If (ubA > lo + 1&) Then
> >> lbA = lo + 1&
> >> Else
> >> If cnt = 0& Then
> >> Exit Sub
> >> End If
> >> lbA = lbs(cnt)
> >> ubA = ubs(cnt)
> >> cnt = cnt - 1&
> >> End If
> >> End If
> >> Loop
> >> '----===========----
> >> Else '-Blizzard v4 ©Rd-
> >> '----===========----
> >> Do
> >> hi = ((ubA - lbA) \ 2&) + lbA ' Get pivot
> >> item = lA(hi)
> >> lA(hi) = lA(ubA) ' Grab current
> >> lo = lbA
> >> hi = ubA ' Set bounds
> >>
> >> Do While (hi > lo) ' Storm right in
> >> If (lA(lo) > item) Then
> >> lA(hi) = lA(lo)
> >> hi = hi - 1&
> >> Do Until (hi = lo)
> >> If (item > lA(hi)) Then
> >> lA(lo) = lA(hi)
> >> Exit Do
> >> End If
> >> hi = hi - 1&
> >> Loop ' Found swaps or out of loop
> >> If (lo = hi) Then
> >> Exit Do
> >> End If
> >> End If
> >> lo = lo + 1&
> >> Loop
> >>
> >> lA(hi) = item ' Re-assign current
> >>
> >> If (lbA < lo - 1&) Then
> >> If (ubA > lo + 1&) Then
> >> cnt = cnt + 1&
> >> lbs(cnt) = lo + 1&
> >> End If
> >> ubs(cnt) = ubA
> >> ubA = lo - 1&
> >> Else
> >> If (ubA > lo + 1&) Then
> >> lbA = lo + 1&
> >> Else
> >> If cnt = 0& Then
> >> Exit Sub
> >> End If
> >> lbA = lbs(cnt)
> >> ubA = ubs(cnt)
> >> cnt = cnt - 1&
> >> '----===========----
> >> End If
> >> End If
> >> Loop
> >> End If
> >> '----===========----
> >>
> >> End Sub
> >>
> >>
> >> When I test like this:
> >>
> >> Sub test()
> >>
> >> Dim i As Long
> >> Dim arr(1 To 10) As Long
> >>
> >> For i = 1 To 10
> >> arr(i) = 11 - i
> >> Debug.Print arr(i)
> >> Next
> >>
> >> Debug.Print "--------------"
> >>
> >> lngSwap4 arr, 1, 10
> >>
> >> For i = 1 To 10
> >> Debug.Print arr(i)
> >> Next
> >>
> >> End Sub
> >>
> >> I consistently get the following output:
> >>
> >> 10
> >> 9
> >> 8
> >> 7
> >> 6
> >> 5
> >> 4
> >> 3
> >> 2
> >> 1
> >> --------------
> >> 1
> >> 2
> >> 5
> >> 4
> >> 3
> >> 6
> >> 7
> >> 8
> >> 9
> >> 10
> >>
> >>
> >> Has anybody used this code and made it to work?
> >>
> >>
> >> RBS
> >>
> >
> >
>

[RB Smissaert]

When I use your code and run this:

Sub test()

Dim i As Long
Dim arUB As Long
arUB = 100 ' > change
ReDim arr(1 To arUB) As Long

For i = 1 To arUB
arr(i) = arUB + 1 - i
'Debug.Print arr(i)
Next

'Debug.Print "--------------"

lngSwap5 arr, 1, arUB

For i = 1 To arUB
Debug.Print arr(i)
Next

End Sub

It still has the wrong output.
I am sure Rd will tell me soon how it should be fixed.

RBS


"Bob Phillips" <bob.NGs@somewhere.com> wrote in message
news:%238qL3PFmGHA.1812@TK2MSFTNGP04.phx.gbl...
>I am not surprised, as it didn't seem to use anything particularly VBA.
>
> Bob
>
> "RB Smissaert" <bartsmissaert@blueyonder.co.uk> wrote in message
> news:u%23Ma8MFmGHA.4772@TK2MSFTNGP04.phx.gbl...
>> Yes, tried in VB and exactly same faults.
>>
>> RBS
>>
>> "Bob Phillips" <bob.NGs@somewhere.com> wrote in message
>> news:%23F7pNAFmGHA.464@TK2MSFTNGP05.phx.gbl...
>> > Bart,
>> >
>> > Have you tried it in VB, and does it work?
>> >
>> > It seems to sort fine, then does one more loop where it swaps two items
>> > that
>> > are in order. This mod seems to work
>> >
>> > Private Sub lngSwap4(lA() As Long, _
>> > ByVal lbA As Long, _
>> > ByVal ubA As Long, _
>> > Optional ByVal bDescending As Boolean)
>> >
>> > ' This is my non-recursive Quick-Sort, and is very very fast!
>> > Dim lo As Long
>> > Dim hi As Long
>> > Dim cnt As Long
>> > Dim item As Long
>> >
>> > lo = ((ubA - lbA) \ 8&) + 16& ' Allow for worst case senario
>> >
>> > If lo > 0& Then
>> > ReDim lbs(1& To lo) As Long
>> > ReDim ubs(1& To lo) As Long
>> > End If
>> >
>> > '----==========----
>> > If bDescending Then
>> > '----==========----
>> > Do
>> > hi = ((ubA - lbA) \ 2&) + lbA ' Get pivot
>> > item = lA(hi)
>> > lA(hi) = lA(ubA) ' Grab current
>> > lo = lbA
>> > hi = ubA ' Set bounds
>> >
>> > Do While (hi > lo) ' Storm right in
>> > If (lA(lo) < item) Then
>> > lA(hi) = lA(lo)
>> > hi = hi - 1&
>> > Do Until (hi = lo)
>> > If (item < lA(hi)) Then
>> > lA(lo) = lA(hi)
>> > Exit Do
>> > End If
>> > hi = hi - 1&
>> > Loop ' Found swaps or out of loop
>> > If (lo = hi) Then
>> > Exit Do
>> > End If
>> > End If
>> > lo = lo + 1&
>> > Loop
>> >
>> > lA(hi) = item ' Re-assign current
>> >
>> > If (lbA < lo - 1&) Then
>> > If (ubA > lo + 1&) Then
>> > cnt = cnt + 1&
>> > lbs(cnt) = lo + 1&
>> > End If
>> > ubs(cnt) = ubA
>> > ubA = lo - 1&
>> > Else
>> > If (ubA > lo + 1&) Then
>> > lbA = lo + 1&
>> > Else
>> > If cnt = 0& Then
>> > Exit Sub
>> > End If
>> > lbA = lbs(cnt)
>> > ubA = ubs(cnt)
>> > cnt = cnt - 1&
>> > End If
>> > End If
>> > Loop While cnt <> 0
>> > '----===========----
>> > Else '-Blizzard v4 ©Rd-
>> > '----===========----
>> > Do
>> > hi = ((ubA - lbA) \ 2&) + lbA ' Get pivot
>> > item = lA(hi)
>> > lA(hi) = lA(ubA) ' Grab current
>> > lo = lbA
>> > hi = ubA ' Set bounds
>> >
>> > Do While (hi > lo) ' Storm right in
>> > If (lA(lo) > item) Then
>> > lA(hi) = lA(lo)
>> > hi = hi - 1&
>> > Do Until (hi = lo)
>> > If (item > lA(hi)) Then
>> > lA(lo) = lA(hi)
>> > Exit Do
>> > End If
>> > hi = hi - 1&
>> > Loop ' Found swaps or out of loop
>> > If (lo = hi) Then
>> > Exit Do
>> > End If
>> > End If
>> > lo = lo + 1&
>> > Loop
>> >
>> > lA(hi) = item ' Re-assign current
>> >
>> > If (lbA < lo - 1&) Then
>> > If (ubA > lo + 1&) Then
>> > cnt = cnt + 1&
>> > lbs(cnt) = lo + 1&
>> > End If
>> > ubs(cnt) = ubA
>> > ubA = lo - 1&
>> > Else
>> > If (ubA > lo + 1&) Then
>> > lbA = lo + 1&
>> > Else
>> > If cnt = 0& Then
>> > Exit Sub
>> > End If
>> > lbA = lbs(cnt)
>> > ubA = ubs(cnt)
>> > cnt = cnt - 1&
>> > '----===========----
>> > End If
>> > End If
>> > Loop While cnt <> 0
>> > End If
>> > '----===========----
>> >
>> > End Sub
>> >
>> > --
>> > HTH
>> >
>> > Bob Phillips
>> >
>> > (replace somewhere in email address with gmail if mailing direct)
>> >
>> > "RB Smissaert" <bartsmissaert@blueyonder.co.uk> wrote in message
>> > news:OjyY6hDmGHA.856@TK2MSFTNGP03.phx.gbl...
>> >> Got the following QuickSort from Rd Edwards (posted on Planet Source
> Code
>> > as
>> >> well).
>> >> I think the has coded and tested in VB6 and says it works fine, but
> when
>> >> I
>> >> run it in VBA it doesn't sort
>> >> properly.
>> >> Can't imagine that running it from VBA would make any difference, but
>> >> have
>> >> otherwise no idea why it doesn't work.
>> >> Actually, I have now tested this in a VB6 .exe and exactly same output
> as
>> > in
>> >> VBA, so it doesn't sort properly there either.
>> >>
>> >> Option Explicit
>> >> Private lbs() As Long, ubs() As Long ' qs v4 non-recursive stacks
>> >>
>> >> Private Sub lngSwap4(lA() As Long, _
>> >> ByVal lbA As Long, _
>> >> ByVal ubA As Long, _
>> >> Optional ByVal bDescending As Boolean)
>> >>
>> >> ' This is my non-recursive Quick-Sort, and is very very fast!
>> >> Dim lo As Long
>> >> Dim hi As Long
>> >> Dim cnt As Long
>> >> Dim item As Long
>> >>
>> >> lo = ((ubA - lbA) \ 8&) + 16& ' Allow for worst case senario
>> >>
>> >> If lo > 0& Then
>> >> ReDim lbs(1& To lo) As Long
>> >> ReDim ubs(1& To lo) As Long
>> >> End If
>> >>
>> >> '----==========----
>> >> If bDescending Then
>> >> '----==========----
>> >> Do
>> >> hi = ((ubA - lbA) \ 2&) + lbA ' Get pivot
>> >> item = lA(hi)
>> >> lA(hi) = lA(ubA) ' Grab current
>> >> lo = lbA
>> >> hi = ubA ' Set bounds
>> >>
>> >> Do While (hi > lo) ' Storm right in
>> >> If (lA(lo) < item) Then
>> >> lA(hi) = lA(lo)
>> >> hi = hi - 1&
>> >> Do Until (hi = lo)
>> >> If (item < lA(hi)) Then
>> >> lA(lo) = lA(hi)
>> >> Exit Do
>> >> End If
>> >> hi = hi - 1&
>> >> Loop ' Found swaps or out of loop
>> >> If (lo = hi) Then
>> >> Exit Do
>> >> End If
>> >> End If
>> >> lo = lo + 1&
>> >> Loop
>> >>
>> >> lA(hi) = item ' Re-assign current
>> >>
>> >> If (lbA < lo - 1&) Then
>> >> If (ubA > lo + 1&) Then
>> >> cnt = cnt + 1&
>> >> lbs(cnt) = lo + 1&
>> >> End If
>> >> ubs(cnt) = ubA
>> >> ubA = lo - 1&
>> >> Else
>> >> If (ubA > lo + 1&) Then
>> >> lbA = lo + 1&
>> >> Else
>> >> If cnt = 0& Then
>> >> Exit Sub
>> >> End If
>> >> lbA = lbs(cnt)
>> >> ubA = ubs(cnt)
>> >> cnt = cnt - 1&
>> >> End If
>> >> End If
>> >> Loop
>> >> '----===========----
>> >> Else '-Blizzard v4 ©Rd-
>> >> '----===========----
>> >> Do
>> >> hi = ((ubA - lbA) \ 2&) + lbA ' Get pivot
>> >> item = lA(hi)
>> >> lA(hi) = lA(ubA) ' Grab current
>> >> lo = lbA
>> >> hi = ubA ' Set bounds
>> >>
>> >> Do While (hi > lo) ' Storm right in
>> >> If (lA(lo) > item) Then
>> >> lA(hi) = lA(lo)
>> >> hi = hi - 1&
>> >> Do Until (hi = lo)
>> >> If (item > lA(hi)) Then
>> >> lA(lo) = lA(hi)
>> >> Exit Do
>> >> End If
>> >> hi = hi - 1&
>> >> Loop ' Found swaps or out of loop
>> >> If (lo = hi) Then
>> >> Exit Do
>> >> End If
>> >> End If
>> >> lo = lo + 1&
>> >> Loop
>> >>
>> >> lA(hi) = item ' Re-assign current
>> >>
>> >> If (lbA < lo - 1&) Then
>> >> If (ubA > lo + 1&) Then
>> >> cnt = cnt + 1&
>> >> lbs(cnt) = lo + 1&
>> >> End If
>> >> ubs(cnt) = ubA
>> >> ubA = lo - 1&
>> >> Else
>> >> If (ubA > lo + 1&) Then
>> >> lbA = lo + 1&
>> >> Else
>> >> If cnt = 0& Then
>> >> Exit Sub
>> >> End If
>> >> lbA = lbs(cnt)
>> >> ubA = ubs(cnt)
>> >> cnt = cnt - 1&
>> >> '----===========----
>> >> End If
>> >> End If
>> >> Loop
>> >> End If
>> >> '----===========----
>> >>
>> >> End Sub
>> >>
>> >>
>> >> When I test like this:
>> >>
>> >> Sub test()
>> >>
>> >> Dim i As Long
>> >> Dim arr(1 To 10) As Long
>> >>
>> >> For i = 1 To 10
>> >> arr(i) = 11 - i
>> >> Debug.Print arr(i)
>> >> Next
>> >>
>> >> Debug.Print "--------------"
>> >>
>> >> lngSwap4 arr, 1, 10
>> >>
>> >> For i = 1 To 10
>> >> Debug.Print arr(i)
>> >> Next
>> >>
>> >> End Sub
>> >>
>> >> I consistently get the following output:
>> >>
>> >> 10
>> >> 9
>> >> 8
>> >> 7
>> >> 6
>> >> 5
>> >> 4
>> >> 3
>> >> 2
>> >> 1
>> >> --------------
>> >> 1
>> >> 2
>> >> 5
>> >> 4
>> >> 3
>> >> 6
>> >> 7
>> >> 8
>> >> 9
>> >> 10
>> >>
>> >>
>> >> Has anybody used this code and made it to work?
>> >>
>> >>
>> >> RBS
>> >>
>> >
>> >
>>
>
>

[RB Smissaert]

This still doesn't solve it with all arrays.
As you say Bob, it carries on when the array is already sorted.

RBS

"RB Smissaert" <bartsmissaert@blueyonder.co.uk> wrote in message
news:%23aHP8KFmGHA.4808@TK2MSFTNGP05.phx.gbl...
> Thanks, will have a look.
> I found this solved it. Also solves an error when
> the array is lbound 1 and ubound 4:
>
> Private Sub lngSwap4(lA() As Long, _
> ByVal lbA As Long, _
> ByVal ubA As Long, _
> Optional ByVal bDescending As Boolean)
>
> ' This is my non-recursive Quick-Sort, and is very very fast!
> Dim lo As Long
> Dim hi As Long
> Dim cnt As Long
> Dim item As Long
>
> lo = ((ubA - lbA) \ 8&) + 16& ' Allow for worst case senario
>
> If lo > 0& Then
> ReDim lbs(1& To lo) As Long
> ReDim ubs(1& To lo) As Long
> End If
>
> '----==========----
> If bDescending Then
> '----==========----
> Do
> hi = ((ubA - lbA) \ 2&) + lbA ' Get pivot
> item = lA(hi)
> lA(hi) = lA(ubA) ' Grab current
> lo = lbA
> hi = ubA ' Set bounds
>
> Do While (hi > lo) ' Storm right in
> If (lA(lo) < item) Then
> lA(hi) = lA(lo)
> hi = hi - 1&
> Do Until (hi = lo)
> If (item < lA(hi)) Then
> lA(lo) = lA(hi)
> Exit Do
> End If
> hi = hi - 1&
> Loop ' Found swaps or out of loop
> If (lo = hi) Then
> Exit Do
> End If
> End If
> lo = lo + 1&
> Loop
>
> lA(hi) = item ' Re-assign current
>
> If (lbA < lo - 1&) Then
> If (ubA > lo + 1&) Then
> cnt = cnt + 1&
> lbs(cnt) = lo + 1&
> End If
>
> 'added code
> '----------
> If cnt < LBound(lA) Then
> cnt = LBound(lA)
> End If
>
> ubs(cnt) = ubA
> ubA = lo - 1&
> Else
> If (ubA > lo + 1&) Then
> lbA = lo + 1&
>
> Else
> If cnt = 0& Then
> Exit Sub
> End If
> lbA = lbs(cnt)
>
> ubA = ubs(cnt)
> cnt = cnt - 1&
> End If
> End If
> Loop
> '----===========----
> Else '-Blizzard v4 ©Rd-
> '----===========----
> Do
> hi = ((ubA - lbA) \ 2&) + lbA ' Get pivot
> item = lA(hi)
> lA(hi) = lA(ubA) ' Grab current
> lo = lbA
> hi = ubA ' Set bounds
>
> Do While (hi > lo) ' Storm right in
> If (lA(lo) > item) Then
> lA(hi) = lA(lo)
> hi = hi - 1&
> Do Until (hi = lo)
> If (item > lA(hi)) Then
> lA(lo) = lA(hi)
> Exit Do
> End If
> hi = hi - 1&
> Loop ' Found swaps or out of loop
> If (lo = hi) Then
> Exit Do
> End If
> End If
> lo = lo + 1&
> Loop
>
> lA(hi) = item ' Re-assign current
>
> If (lbA < lo - 1&) Then
> If (ubA > lo + 1&) Then
> cnt = cnt + 1&
> lbs(cnt) = lo + 1&
> End If
>
> 'added code
> '----------
> If cnt < LBound(lA) Then
> cnt = LBound(lA)
> End If
>
> ubs(cnt) = ubA
> ubA = lo - 1&
> Else
> If (ubA > lo + 1&) Then
> lbA = lo + 1&
>
> Else
> If cnt = 0& Then
> Exit Sub
> End If
>
> ubA = ubs(cnt)
> cnt = cnt - 1&
> '----===========----
> End If
> End If
> Loop
> End If
> '----===========----
>
> End Sub
>
>
> RBS
>
>
>
> "Bob Phillips" <bob.NGs@somewhere.com> wrote in message
> news:%23F7pNAFmGHA.464@TK2MSFTNGP05.phx.gbl...
>> Bart,
>>
>> Have you tried it in VB, and does it work?
>>
>> It seems to sort fine, then does one more loop where it swaps two items
>> that
>> are in order. This mod seems to work
>>
>> Private Sub lngSwap4(lA() As Long, _
>> ByVal lbA As Long, _
>> ByVal ubA As Long, _
>> Optional ByVal bDescending As Boolean)
>>
>> ' This is my non-recursive Quick-Sort, and is very very fast!
>> Dim lo As Long
>> Dim hi As Long
>> Dim cnt As Long
>> Dim item As Long
>>
>> lo = ((ubA - lbA) \ 8&) + 16& ' Allow for worst case senario
>>
>> If lo > 0& Then
>> ReDim lbs(1& To lo) As Long
>> ReDim ubs(1& To lo) As Long
>> End If
>>
>> '----==========----
>> If bDescending Then
>> '----==========----
>> Do
>> hi = ((ubA - lbA) \ 2&) + lbA ' Get pivot
>> item = lA(hi)
>> lA(hi) = lA(ubA) ' Grab current
>> lo = lbA
>> hi = ubA ' Set bounds
>>
>> Do While (hi > lo) ' Storm right in
>> If (lA(lo) < item) Then
>> lA(hi) = lA(lo)
>> hi = hi - 1&
>> Do Until (hi = lo)
>> If (item < lA(hi)) Then
>> lA(lo) = lA(hi)
>> Exit Do
>> End If
>> hi = hi - 1&
>> Loop ' Found swaps or out of loop
>> If (lo = hi) Then
>> Exit Do
>> End If
>> End If
>> lo = lo + 1&
>> Loop
>>
>> lA(hi) = item ' Re-assign current
>>
>> If (lbA < lo - 1&) Then
>> If (ubA > lo + 1&) Then
>> cnt = cnt + 1&
>> lbs(cnt) = lo + 1&
>> End If
>> ubs(cnt) = ubA
>> ubA = lo - 1&
>> Else
>> If (ubA > lo + 1&) Then
>> lbA = lo + 1&
>> Else
>> If cnt = 0& Then
>> Exit Sub
>> End If
>> lbA = lbs(cnt)
>> ubA = ubs(cnt)
>> cnt = cnt - 1&
>> End If
>> End If
>> Loop While cnt <> 0
>> '----===========----
>> Else '-Blizzard v4 ©Rd-
>> '----===========----
>> Do
>> hi = ((ubA - lbA) \ 2&) + lbA ' Get pivot
>> item = lA(hi)
>> lA(hi) = lA(ubA) ' Grab current
>> lo = lbA
>> hi = ubA ' Set bounds
>>
>> Do While (hi > lo) ' Storm right in
>> If (lA(lo) > item) Then
>> lA(hi) = lA(lo)
>> hi = hi - 1&
>> Do Until (hi = lo)
>> If (item > lA(hi)) Then
>> lA(lo) = lA(hi)
>> Exit Do
>> End If
>> hi = hi - 1&
>> Loop ' Found swaps or out of loop
>> If (lo = hi) Then
>> Exit Do
>> End If
>> End If
>> lo = lo + 1&
>> Loop
>>
>> lA(hi) = item ' Re-assign current
>>
>> If (lbA < lo - 1&) Then
>> If (ubA > lo + 1&) Then
>> cnt = cnt + 1&
>> lbs(cnt) = lo + 1&
>> End If
>> ubs(cnt) = ubA
>> ubA = lo - 1&
>> Else
>> If (ubA > lo + 1&) Then
>> lbA = lo + 1&
>> Else
>> If cnt = 0& Then
>> Exit Sub
>> End If
>> lbA = lbs(cnt)
>> ubA = ubs(cnt)
>> cnt = cnt - 1&
>> '----===========----
>> End If
>> End If
>> Loop While cnt <> 0
>> End If
>> '----===========----
>>
>> End Sub
>>
>> --
>> HTH
>>
>> Bob Phillips
>>
>> (replace somewhere in email address with gmail if mailing direct)
>>
>> "RB Smissaert" <bartsmissaert@blueyonder.co.uk> wrote in message
>> news:OjyY6hDmGHA.856@TK2MSFTNGP03.phx.gbl...
>>> Got the following QuickSort from Rd Edwards (posted on Planet Source
>>> Code
>> as
>>> well).
>>> I think the has coded and tested in VB6 and says it works fine, but when
>>> I
>>> run it in VBA it doesn't sort
>>> properly.
>>> Can't imagine that running it from VBA would make any difference, but
>>> have
>>> otherwise no idea why it doesn't work.
>>> Actually, I have now tested this in a VB6 .exe and exactly same output
>>> as
>> in
>>> VBA, so it doesn't sort properly there either.
>>>
>>> Option Explicit
>>> Private lbs() As Long, ubs() As Long ' qs v4 non-recursive stacks
>>>
>>> Private Sub lngSwap4(lA() As Long, _
>>> ByVal lbA As Long, _
>>> ByVal ubA As Long, _
>>> Optional ByVal bDescending As Boolean)
>>>
>>> ' This is my non-recursive Quick-Sort, and is very very fast!
>>> Dim lo As Long
>>> Dim hi As Long
>>> Dim cnt As Long
>>> Dim item As Long
>>>
>>> lo = ((ubA - lbA) \ 8&) + 16& ' Allow for worst case senario
>>>
>>> If lo > 0& Then
>>> ReDim lbs(1& To lo) As Long
>>> ReDim ubs(1& To lo) As Long
>>> End If
>>>
>>> '----==========----
>>> If bDescending Then
>>> '----==========----
>>> Do
>>> hi = ((ubA - lbA) \ 2&) + lbA ' Get pivot
>>> item = lA(hi)
>>> lA(hi) = lA(ubA) ' Grab current
>>> lo = lbA
>>> hi = ubA ' Set bounds
>>>
>>> Do While (hi > lo) ' Storm right in
>>> If (lA(lo) < item) Then
>>> lA(hi) = lA(lo)
>>> hi = hi - 1&
>>> Do Until (hi = lo)
>>> If (item < lA(hi)) Then
>>> lA(lo) = lA(hi)
>>> Exit Do
>>> End If
>>> hi = hi - 1&
>>> Loop ' Found swaps or out of loop
>>> If (lo = hi) Then
>>> Exit Do
>>> End If
>>> End If
>>> lo = lo + 1&
>>> Loop
>>>
>>> lA(hi) = item ' Re-assign current
>>>
>>> If (lbA < lo - 1&) Then
>>> If (ubA > lo + 1&) Then
>>> cnt = cnt + 1&
>>> lbs(cnt) = lo + 1&
>>> End If
>>> ubs(cnt) = ubA
>>> ubA = lo - 1&
>>> Else
>>> If (ubA > lo + 1&) Then
>>> lbA = lo + 1&
>>> Else
>>> If cnt = 0& Then
>>> Exit Sub
>>> End If
>>> lbA = lbs(cnt)
>>> ubA = ubs(cnt)
>>> cnt = cnt - 1&
>>> End If
>>> End If
>>> Loop
>>> '----===========----
>>> Else '-Blizzard v4 ©Rd-
>>> '----===========----
>>> Do
>>> hi = ((ubA - lbA) \ 2&) + lbA ' Get pivot
>>> item = lA(hi)
>>> lA(hi) = lA(ubA) ' Grab current
>>> lo = lbA
>>> hi = ubA ' Set bounds
>>>
>>> Do While (hi > lo) ' Storm right in
>>> If (lA(lo) > item) Then
>>> lA(hi) = lA(lo)
>>> hi = hi - 1&
>>> Do Until (hi = lo)
>>> If (item > lA(hi)) Then
>>> lA(lo) = lA(hi)
>>> Exit Do
>>> End If
>>> hi = hi - 1&
>>> Loop ' Found swaps or out of loop
>>> If (lo = hi) Then
>>> Exit Do
>>> End If
>>> End If
>>> lo = lo + 1&
>>> Loop
>>>
>>> lA(hi) = item ' Re-assign current
>>>
>>> If (lbA < lo - 1&) Then
>>> If (ubA > lo + 1&) Then
>>> cnt = cnt + 1&
>>> lbs(cnt) = lo + 1&
>>> End If
>>> ubs(cnt) = ubA
>>> ubA = lo - 1&
>>> Else
>>> If (ubA > lo + 1&) Then
>>> lbA = lo + 1&
>>> Else
>>> If cnt = 0& Then
>>> Exit Sub
>>> End If
>>> lbA = lbs(cnt)
>>> ubA = ubs(cnt)
>>> cnt = cnt - 1&
>>> '----===========----
>>> End If
>>> End If
>>> Loop
>>> End If
>>> '----===========----
>>>
>>> End Sub
>>>
>>>
>>> When I test like this:
>>>
>>> Sub test()
>>>
>>> Dim i As Long
>>> Dim arr(1 To 10) As Long
>>>
>>> For i = 1 To 10
>>> arr(i) = 11 - i
>>> Debug.Print arr(i)
>>> Next
>>>
>>> Debug.Print "--------------"
>>>
>>> lngSwap4 arr, 1, 10
>>>
>>> For i = 1 To 10
>>> Debug.Print arr(i)
>>> Next
>>>
>>> End Sub
>>>
>>> I consistently get the following output:
>>>
>>> 10
>>> 9
>>> 8
>>> 7
>>> 6
>>> 5
>>> 4
>>> 3
>>> 2
>>> 1
>>> --------------
>>> 1
>>> 2
>>> 5
>>> 4
>>> 3
>>> 6
>>> 7
>>> 8
>>> 9
>>> 10
>>>
>>>
>>> Has anybody used this code and made it to work?
>>>
>>>
>>> RBS
>>>
>>
>>
>

[Howard Kaikow]

See http://www.standards.com/index.html?Sorting for a bunch of algorithms
that work.

[RB Smissaert]

Well, I have the regular/standard QuickSort and that is pretty fast, but I
thought
this might be faster. Shame it doesn't sort.

RBS

"Howard Kaikow" <kaikow@standards.com> wrote in message
news:%23bC42jImGHA.508@TK2MSFTNGP03.phx.gbl...
> See http://www.standards.com/index.html?Sorting for a bunch of algorithms
> that work.
>
>

[Bob Phillips]

ah, but it is faster <vbg>

"RB Smissaert" <bartsmissaert@blueyonder.co.uk> wrote in message
news:u$is0uJmGHA.4696@TK2MSFTNGP05.phx.gbl...
> Well, I have the regular/standard QuickSort and that is pretty fast, but I
> thought
> this might be faster. Shame it doesn't sort.
>
> RBS
>
> "Howard Kaikow" <kaikow@standards.com> wrote in message
> news:%23bC42jImGHA.508@TK2MSFTNGP03.phx.gbl...
> > See http://www.standards.com/index.html?Sorting for a bunch of
algorithms
> > that work.
> >
> >
>

[RB Smissaert]

If being fast was the main thing I could make it much faster and simpler at
the same time

RBS

"Bob Phillips" <bob.NGs@somewhere.com> wrote in message
news:OI9VwVKmGHA.492@TK2MSFTNGP05.phx.gbl...
> ah, but it is faster <vbg>
>
> "RB Smissaert" <bartsmissaert@blueyonder.co.uk> wrote in message
> news:u$is0uJmGHA.4696@TK2MSFTNGP05.phx.gbl...
>> Well, I have the regular/standard QuickSort and that is pretty fast, but
>> I
>> thought
>> this might be faster. Shame it doesn't sort.
>>
>> RBS
>>
>> "Howard Kaikow" <kaikow@standards.com> wrote in message
>> news:%23bC42jImGHA.508@TK2MSFTNGP03.phx.gbl...
>> > See http://www.standards.com/index.html?Sorting for a bunch of
> algorithms
>> > that work.
>> >
>> >
>>
>
>

[Bob Phillips]

LOL!

"RB Smissaert" <bartsmissaert@blueyonder.co.uk> wrote in message
news:OgLxYeKmGHA.4776@TK2MSFTNGP05.phx.gbl...
> If being fast was the main thing I could make it much faster and simpler
at
> the same time
>
> RBS
>
> "Bob Phillips" <bob.NGs@somewhere.com> wrote in message
> news:OI9VwVKmGHA.492@TK2MSFTNGP05.phx.gbl...
> > ah, but it is faster <vbg>
> >
> > "RB Smissaert" <bartsmissaert@blueyonder.co.uk> wrote in message
> > news:u$is0uJmGHA.4696@TK2MSFTNGP05.phx.gbl...
> >> Well, I have the regular/standard QuickSort and that is pretty fast,
but
> >> I
> >> thought
> >> this might be faster. Shame it doesn't sort.
> >>
> >> RBS
> >>
> >> "Howard Kaikow" <kaikow@standards.com> wrote in message
> >> news:%23bC42jImGHA.508@TK2MSFTNGP03.phx.gbl...
> >> > See http://www.standards.com/index.html?Sorting for a bunch of
> > algorithms
> >> > that work.
> >> >
> >> >
> >>
> >
> >
>

[Michael C]

"RB Smissaert" <bartsmissaert@blueyonder.co.uk> wrote in message
news:OjyY6hDmGHA.856@TK2MSFTNGP03.phx.gbl...
> Got the following QuickSort from Rd Edwards (posted on Planet Source Code
> as well).
> I think the has coded and tested in VB6 and says it works fine, but when I
> run it in VBA it doesn't sort
> properly.
> Can't imagine that running it from VBA would make any difference, but have
> otherwise no idea why it doesn't work.
> Actually, I have now tested this in a VB6 .exe and exactly same output as
> in VBA, so it doesn't sort properly there either.

Try the sort on this page, it is around the same speed I believe but *much*
simpler.

http://www.mikesdriveway.com/code/

Michael

[Howard Kaikow]

"RB Smissaert" <bartsmissaert@blueyonder.co.uk> wrote in message
news:u$is0uJmGHA.4696@TK2MSFTNGP05.phx.gbl...
> Well, I have the regular/standard QuickSort and that is pretty fast, but I
> thought
> this might be faster. Shame it doesn't sort.

There is no standard QuickSort.
There are many variants of the algorithm.

[RB Smissaert]

No, I know there isn't a standard one as such, but this is the one that is
uploaded
and used the by far the most.
This is for an ascending sort of a 2-D array of long values:


Sub QuickSortALong2D(arrLong() As Long, _
lKey As Long, _
Optional lLow1 As Long = -1, _
Optional lHigh1 As Long = -1)

Dim lLow2 As Long
Dim lHigh2 As Long
Dim c As Long
Dim lItem1 As Long
Dim lItem2 As Long
Dim LB2 As Long
Dim UB2 As Long

On Error GoTo 0 'turn off error handling, bit faster

If lLow1 = -1 Then
lLow1 = LBound(arrLong)
End If

If lHigh1 = -1 Then
lHigh1 = UBound(arrLong)
End If

'otherwise this will have to be determined everytime in the for loop
'-------------------------------------------------------------------
LB2 = LBound(arrLong, 2)
UB2 = UBound(arrLong, 2)

'Set new extremes to old extremes
lLow2 = lLow1
lHigh2 = lHigh1

'Get value of array item in middle of new extremes
'maybe random pivot point better here for partially sorted arrays?
'tested and doesn't look it is better
'-----------------------------------------------------------------
lItem1 = arrLong((lLow1 + lHigh1) \ 2, lKey)

'Loop for all the items in the array between the extremes
While lLow2 < lHigh2

'Find the first item that is greater than the mid-point item
While arrLong(lLow2, lKey) < lItem1 And lLow2 < lHigh1
lLow2 = lLow2 + 1
Wend

'Find the last item that is less than the mid-point item
While arrLong(lHigh2, lKey) > lItem1 And lHigh2 > lLow1
lHigh2 = lHigh2 - 1
Wend

'If the two items are in the wrong order, swap the rows
If lLow2 < lHigh2 Then
For c = LB2 To UB2
lItem2 = arrLong(lLow2, c)
arrLong(lLow2, c) = arrLong(lHigh2, c)
arrLong(lHigh2, c) = lItem2
Next
End If

'If the pointers are not together, advance to the next item
If lLow2 <= lHigh2 Then
lLow2 = lLow2 + 1
lHigh2 = lHigh2 - 1
End If
Wend

'Recurse to sort the lower half of the extremes
If lHigh2 > lLow1 Then QuickSortALong2D arrLong, lKey, lLow1, lHigh2

'Recurse to sort the upper half of the extremes
If lLow2 < lHigh1 Then QuickSortALong2D arrLong, lKey, lLow2, lHigh1

End Sub


RBS


"Howard Kaikow" <kaikow@standards.com> wrote in message
news:ev5BikQmGHA.4868@TK2MSFTNGP04.phx.gbl...
> "RB Smissaert" <bartsmissaert@blueyonder.co.uk> wrote in message
> news:u$is0uJmGHA.4696@TK2MSFTNGP05.phx.gbl...
>> Well, I have the regular/standard QuickSort and that is pretty fast, but
>> I
>> thought
>> this might be faster. Shame it doesn't sort.
>
> There is no standard QuickSort.
> There are many variants of the algorithm.
>
>

[RB Smissaert]

Mea Culpa! I messed up here.

As I don't like the construction with multiple statements on the same line
separated by : and same
for ElseIf constructions I had altered the original code. Went back to the
original code and all
working fine now. I thought I did have the same trouble with the original
code, but that must not
be so then.
Sorry if I have wasted anybody's time.

Now comparing this non-recursive QuickSort with the "standard" recursive one
it shows that it is
indeed faster, but not that much, about 10%. Still, there might be the added
advantage of it not
being recursive as understand that that can cause out of memory problems
with very large arrays.


Here all the original code:

Private lbs() As Long, ubs() As Long ' qs v4 non-recursive stacks

Private Sub lngSwap4(lA() As Long, _
ByVal lbA As Long, _
ByVal ubA As Long, _
Optional ByVal bDescending As Boolean)

' This is my non-recursive Quick-Sort, and is very very fast!
Dim lo As Long
Dim hi As Long
Dim cnt As Long
Dim item As Long

lo = ((ubA - lbA) \ 8&) + 16& ' Allow for worst case senario

If lo > 0& Then
ReDim lbs(1& To lo) As Long
ReDim ubs(1& To lo) As Long
End If

'----==========----
If bDescending Then
'----==========----
Do: hi = ((ubA - lbA) \ 2&) + lbA ' Get pivot
item = lA(hi): lA(hi) = lA(ubA) ' Grab current
lo = lbA: hi = ubA ' Set bounds
Do While (hi > lo) ' Storm right in
If (lA(lo) < item) Then
lA(hi) = lA(lo): hi = hi - 1&
Do Until (hi = lo)
If (item < lA(hi)) Then
lA(lo) = lA(hi): Exit Do
End If
hi = hi - 1&
Loop ' Found swaps or out of loop
If (lo = hi) Then Exit Do
End If
lo = lo + 1&
Loop
lA(hi) = item ' Re-assign current
If (lbA < lo - 1&) Then
If (ubA > lo + 1&) Then cnt = cnt + 1&: lbs(cnt) = lo + 1&:
ubs(cnt) = ubA
ubA = lo - 1&
ElseIf (ubA > lo + 1&) Then
lbA = lo + 1&
Else
If cnt = 0& Then Exit Sub
lbA = lbs(cnt): ubA = ubs(cnt): cnt = cnt - 1&
End If: Loop
'----===========----
Else '-Blizzard v4 ©Rd-
'----===========----
Do: hi = ((ubA - lbA) \ 2&) + lbA ' Get pivot
item = lA(hi): lA(hi) = lA(ubA) ' Grab current
lo = lbA: hi = ubA ' Set bounds
Do While (hi > lo) ' Storm right in
If (lA(lo) > item) Then
lA(hi) = lA(lo): hi = hi - 1&
Do Until (hi = lo)
If (item > lA(hi)) Then
lA(lo) = lA(hi): Exit Do
End If
hi = hi - 1&
Loop ' Found swaps or out of loop
If (lo = hi) Then Exit Do
End If
lo = lo + 1&
Loop
lA(hi) = item ' Re-assign current
If (lbA < lo - 1&) Then
If (ubA > lo + 1&) Then cnt = cnt + 1&: lbs(cnt) = lo + 1&:
ubs(cnt) = ubA
ubA = lo - 1&
ElseIf (ubA > lo + 1&) Then
lbA = lo + 1&
Else
If cnt = 0& Then Exit Sub
lbA = lbs(cnt): ubA = ubs(cnt): cnt = cnt - 1&
'----===========----
End If: Loop: End If
'----===========----

End Sub

Private Sub lngSwap4Indexed(lA() As Long, _
idxA() As Long, _
ByVal lbA As Long, _
ByVal ubA As Long, _
Optional ByVal bDescending As Boolean)

' This is my non-recursive indexed Quick-Sort, and is very very fast!
Dim lo As Long
Dim hi As Long
Dim cnt As Long
Dim item As Long

lo = ((ubA - lbA) \ 8&) + 16& ' Allow for worst case senario

If lo > 0& Then
ReDim lbs(1& To lo) As Long
ReDim ubs(1& To lo) As Long
End If

'----==========----
If bDescending Then
'----==========----
Do: hi = ((ubA - lbA) \ 2&) + lbA ' Get pivot
item = idxA(hi): idxA(hi) = idxA(ubA) ' Grab current index
lo = lbA: hi = ubA ' Set bounds
Do While (hi > lo) ' Storm right in
If (lA(idxA(lo)) < lA(item)) Then
idxA(hi) = idxA(lo): hi = hi - 1&
Do Until (hi = lo)
If (lA(item) < lA(idxA(hi))) Then
idxA(lo) = idxA(hi): Exit Do
End If
hi = hi - 1&
Loop ' Found swaps or out of loop
If (lo = hi) Then Exit Do
End If
lo = lo + 1&
Loop
idxA(hi) = item ' Re-assign current index
If (lbA < lo - 1&) Then
If (ubA > lo + 1&) Then cnt = cnt + 1&: lbs(cnt) = lo + 1&:
ubs(cnt) = ubA
ubA = lo - 1&
ElseIf (ubA > lo + 1&) Then
lbA = lo + 1&
Else
If cnt = 0& Then Exit Sub
lbA = lbs(cnt): ubA = ubs(cnt): cnt = cnt - 1&
End If: Loop
'----===========----
Else '-Blizzard v4 ©Rd-
'----===========----
Do: hi = ((ubA - lbA) \ 2&) + lbA ' Get pivot
item = idxA(hi): idxA(hi) = idxA(ubA) ' Grab current index
lo = lbA: hi = ubA ' Set bounds
Do While (hi > lo) ' Storm right in
If (lA(idxA(lo)) > lA(item)) Then
idxA(hi) = idxA(lo): hi = hi - 1&
Do Until (hi = lo)
If (lA(item) > lA(idxA(hi))) Then
idxA(lo) = idxA(hi): Exit Do
End If
hi = hi - 1&
Loop ' Found swaps or out of loop
If (lo = hi) Then Exit Do
End If
lo = lo + 1&
Loop
idxA(hi) = item ' Re-assign current index
If (lbA < lo - 1&) Then
If (ubA > lo + 1&) Then cnt = cnt + 1&: lbs(cnt) = lo + 1&:
ubs(cnt) = ubA
ubA = lo - 1&
ElseIf (ubA > lo + 1&) Then
lbA = lo + 1&
Else
If cnt = 0& Then Exit Sub
lbA = lbs(cnt): ubA = ubs(cnt): cnt = cnt - 1&
'----===========----
End If: Loop: End If
'----===========----

End Sub


lngSwap4 is about 10% faster compared to this "standard" QuickSort:

Sub QuickSortALong1D(arrLong() As Long, _
Optional lLow1 As Long = -1, _
Optional lHigh1 As Long = -1)

Dim lLow2 As Long
Dim lHigh2 As Long
Dim lItem1 As Long
Dim lItem2 As Long

On Error GoTo 0 'turn off error handling, bit faster

If lLow1 = -1 Then
lLow1 = LBound(arrLong)
End If

If lHigh1 = -1 Then
lHigh1 = UBound(arrLong)
End If

'Set new extremes to old extremes
lLow2 = lLow1
lHigh2 = lHigh1

'Get value of array item in middle of new extremes
'maybe random pivot point better here for partially sorted arrays?
'tested and doesn't look it is better
'-----------------------------------------------------------------
lItem1 = arrLong((lLow1 + lHigh1) \ 2)

'Loop for all the items in the array between the extremes
While lLow2 < lHigh2

'Find the first item that is greater than the mid-point item
While arrLong(lLow2) < lItem1 And lLow2 < lHigh1
lLow2 = lLow2 + 1
Wend

'Find the last item that is less than the mid-point item
While arrLong(lHigh2) > lItem1 And lHigh2 > lLow1
lHigh2 = lHigh2 - 1
Wend

'If the two items are in the wrong order, swap the rows
If lLow2 < lHigh2 Then
lItem2 = arrLong(lLow2)
arrLong(lLow2) = arrLong(lHigh2)
arrLong(lHigh2) = lItem2
End If

'If the pointers are not together, advance to the next item
If lLow2 <= lHigh2 Then
lLow2 = lLow2 + 1
lHigh2 = lHigh2 - 1
End If
Wend

'Recurse to sort the lower half of the extremes
If lHigh2 > lLow1 Then QuickSortALong1D arrLong, lLow1, lHigh2

'Recurse to sort the upper half of the extremes
If lLow2 < lHigh1 Then QuickSortALong1D arrLong, lLow2, lHigh1

End Sub


RBS


"RB Smissaert" <bartsmissaert@blueyonder.co.uk> wrote in message
news:OjyY6hDmGHA.856@TK2MSFTNGP03.phx.gbl...
> Got the following QuickSort from Rd Edwards (posted on Planet Source Code
> as well).
> I think the has coded and tested in VB6 and says it works fine, but when I
> run it in VBA it doesn't sort
> properly.
> Can't imagine that running it from VBA would make any difference, but have
> otherwise no idea why it doesn't work.
> Actually, I have now tested this in a VB6 .exe and exactly same output as
> in VBA, so it doesn't sort properly there either.
>
> Option Explicit
> Private lbs() As Long, ubs() As Long ' qs v4 non-recursive stacks
>
> Private Sub lngSwap4(lA() As Long, _
> ByVal lbA As Long, _
> ByVal ubA As Long, _
> Optional ByVal bDescending As Boolean)
>
> ' This is my non-recursive Quick-Sort, and is very very fast!
> Dim lo As Long
> Dim hi As Long
> Dim cnt As Long
> Dim item As Long
>
> lo = ((ubA - lbA) \ 8&) + 16& ' Allow for worst case senario
>
> If lo > 0& Then
> ReDim lbs(1& To lo) As Long
> ReDim ubs(1& To lo) As Long
> End If
>
> '----==========----
> If bDescending Then
> '----==========----
> Do
> hi = ((ubA - lbA) \ 2&) + lbA ' Get pivot
> item = lA(hi)
> lA(hi) = lA(ubA) ' Grab current
> lo = lbA
> hi = ubA ' Set bounds
>
> Do While (hi > lo) ' Storm right in
> If (lA(lo) < item) Then
> lA(hi) = lA(lo)
> hi = hi - 1&
> Do Until (hi = lo)
> If (item < lA(hi)) Then
> lA(lo) = lA(hi)
> Exit Do
> End If
> hi = hi - 1&
> Loop ' Found swaps or out of loop
> If (lo = hi) Then
> Exit Do
> End If
> End If
> lo = lo + 1&
> Loop
>
> lA(hi) = item ' Re-assign current
>
> If (lbA < lo - 1&) Then
> If (ubA > lo + 1&) Then
> cnt = cnt + 1&
> lbs(cnt) = lo + 1&
> End If
> ubs(cnt) = ubA
> ubA = lo - 1&
> Else
> If (ubA > lo + 1&) Then
> lbA = lo + 1&
> Else
> If cnt = 0& Then
> Exit Sub
> End If
> lbA = lbs(cnt)
> ubA = ubs(cnt)
> cnt = cnt - 1&
> End If
> End If
> Loop
> '----===========----
> Else '-Blizzard v4 ©Rd-
> '----===========----
> Do
> hi = ((ubA - lbA) \ 2&) + lbA ' Get pivot
> item = lA(hi)
> lA(hi) = lA(ubA) ' Grab current
> lo = lbA
> hi = ubA ' Set bounds
>
> Do While (hi > lo) ' Storm right in
> If (lA(lo) > item) Then
> lA(hi) = lA(lo)
> hi = hi - 1&
> Do Until (hi = lo)
> If (item > lA(hi)) Then
> lA(lo) = lA(hi)
> Exit Do
> End If
> hi = hi - 1&
> Loop ' Found swaps or out of loop
> If (lo = hi) Then
> Exit Do
> End If
> End If
> lo = lo + 1&
> Loop
>
> lA(hi) = item ' Re-assign current
>
> If (lbA < lo - 1&) Then
> If (ubA > lo + 1&) Then
> cnt = cnt + 1&
> lbs(cnt) = lo + 1&
> End If
> ubs(cnt) = ubA
> ubA = lo - 1&
> Else
> If (ubA > lo + 1&) Then
> lbA = lo + 1&
> Else
> If cnt = 0& Then
> Exit Sub
> End If
> lbA = lbs(cnt)
> ubA = ubs(cnt)
> cnt = cnt - 1&
> '----===========----
> End If
> End If
> Loop
> End If
> '----===========----
>
> End Sub
>
>
> When I test like this:
>
> Sub test()
>
> Dim i As Long
> Dim arr(1 To 10) As Long
>
> For i = 1 To 10
> arr(i) = 11 - i
> Debug.Print arr(i)
> Next
>
> Debug.Print "--------------"
>
> lngSwap4 arr, 1, 10
>
> For i = 1 To 10
> Debug.Print arr(i)
> Next
>
> End Sub
>
> I consistently get the following output:
>
> 10
> 9
> 8
> 7
> 6
> 5
> 4
> 3
> 2
> 1
> --------------
> 1
> 2
> 5
> 4
> 3
> 6
> 7
> 8
> 9
> 10
>
>
> Has anybody used this code and made it to work?
>
>
> RBS
>

[Howard Kaikow]

"RB Smissaert" <bartsmissaert@blueyonder.co.uk> wrote in message
news:uvsDH8QmGHA.3352@TK2MSFTNGP02.phx.gbl...
> No, I know there isn't a standard one as such, but this is the one that is
> uploaded
> and used the by far the most.

And it is not efficient.

Take a look at the code posted at
http://www.standards.com/index.html?Sorting.

[RB Smissaert]

OK, are you saying that to sort a 1-D array of long values a counting sort
is
2 to 3 times faster?
Interesting and I will check that out.
What I didn't see in your webpage is how the VB6 code was compiled.
Is this with all the fast options such as not checking the array bounds etc?

RBS


"Howard Kaikow" <kaikow@standards.com> wrote in message
news:%23hcUP9WmGHA.4076@TK2MSFTNGP03.phx.gbl...
> "RB Smissaert" <bartsmissaert@blueyonder.co.uk> wrote in message
> news:uvsDH8QmGHA.3352@TK2MSFTNGP02.phx.gbl...
>> No, I know there isn't a standard one as such, but this is the one that
>> is
>> uploaded
>> and used the by far the most.
>
> And it is not efficient.
>
> Take a look at the code posted at
> http://www.standards.com/index.html?Sorting.
>
>

[bart.smissaert@gmail.com]

Had a look at the CountingSort and it is faster if the range of values
in the array is
small, but it gets much slower if this range is large. My range is very
large, could be from
0 to 1000000000000.
This simple test will show it won't work for my situation:

Sub Countingsort(List() As Long, _
sorted_list() As Long, _
min As Long, _
max As Long, _
min_value As Long, _
max_value As Long)

Dim counts() As Long
Dim i As Long
Dim this_count As Long
Dim next_offset As Long

'Create the Counts array.
ReDim counts(min_value To max_value)

'give the sorted array the same dimensions as the un-sorted one
ReDim sorted_list(min To max) As Long

'Count the items.
For i = min To max
counts(List(i)) = counts(List(i)) + 1
Next i

'Convert the counts into offsets.
next_offset = min

For i = min_value To max_value
this_count = counts(i)
counts(i) = next_offset
next_offset = next_offset + this_count
Next i

'Place the items in the sorted array.
For i = min To max
sorted_list(counts(List(i))) = List(i)
counts(List(i)) = counts(List(i)) + 1
Next i

End Sub


Sub Test()

Dim i As Long
Dim UB As Long
Dim lFactor As Long
Dim arr() As Long
Dim arrSorted() As Long

UB = 10
lFactor = 1000000

ReDim arr(1 To UB) As Long

For i = 1 To UB
arr(i) = (UB + 1 - i) * lFactor
Next

'arguments:
'--------------------------
'un-sorted original array
'new sorted array
'LBound of the array
'UBound of the array
'minimum value in the array
'maximum value in the array
'---------------------------
Countingsort arr, arrSorted, 1, UB, lFactor, UB * lFactor

Cells.Clear

For i = 1 To UB
Cells(i, 1) = arr(i)
Cells(i, 3) = arrSorted(i)
Next

End Sub


When you say QuickSort not efficient, what is your suggestion then for
a better one
in this situation?


RBS

Howard Kaikow wrote:
> "RB Smissaert" <bartsmissaert@blueyonder.co.uk> wrote in message
> news:uvsDH8QmGHA.3352@TK2MSFTNGP02.phx.gbl...
> > No, I know there isn't a standard one as such, but this is the one that is
> > uploaded
> > and used the by far the most.
>
> And it is not efficient.
>
> Take a look at the code posted at
> http://www.standards.com/index.html?Sorting.

[Michael C]

<bart.smissaert@gmail.com> wrote in message
news:1151395547.351050.316740@c74g2000cwc.googlegroups.com...
> When you say QuickSort not efficient, what is your suggestion then for
> a better one
> in this situation?

Did you check the sort in the link I provided? I'm not sure if it will be
more efficient that quicksort but worth a try.

Michael

[bart.smissaert@gmail.com]

Maybe you should add the code posted by Olaf Schmidt in this NG posting
to sort a 1-D string array to your sorting routines, really fast!

http://shorterlink.co.uk/5583

RBS

Howard Kaikow wrote:
> "RB Smissaert" <bartsmissaert@blueyonder.co.uk> wrote in message
> news:uvsDH8QmGHA.3352@TK2MSFTNGP02.phx.gbl...
> > No, I know there isn't a standard one as such, but this is the one that is
> > uploaded
> > and used the by far the most.
>
> And it is not efficient.
>
> Take a look at the code posted at
> http://www.standards.com/index.html?Sorting.

[bart.smissaert@gmail.com]

Yes, had a quick look at the source and saw some functions without code
and at one
stage I thought you were joking about fast and simple code.
Will give it a try.

RBS

Michael C wrote:
> <bart.smissaert@gmail.com> wrote in message
> news:1151395547.351050.316740@c74g2000cwc.googlegroups.com...
> > When you say QuickSort not efficient, what is your suggestion then for
> > a better one
> > in this situation?
>
> Did you check the sort in the link I provided? I'm not sure if it will be
> more efficient that quicksort but worth a try.
>
> Michael

[Howard Kaikow]

"RB Smissaert" <bartsmissaert@blueyonder.co.uk> wrote in message
news:ePP71nXmGHA.4268@TK2MSFTNGP05.phx.gbl...
> OK, are you saying that to sort a 1-D array of long values a counting sort
> is
> 2 to 3 times faster?
> Interesting and I will check that out.

For integer values, Counting Sot is by far the fastest,

> What I didn't see in your webpage is how the VB6 code was compiled.
> Is this with all the fast options such as not checking the array bounds
etc?

I just use the default values for compiles.

My initial concern was to demonstrate how easy it is to outdo the algorithms
used for sorts within Office.

[Howard Kaikow]

<bart.smissaert@gmail.com> wrote in message
news:1151395547.351050.316740@c74g2000cwc.googlegroups.com...
> Had a look at the CountingSort and it is faster if the range of values
> in the array is
> small, but it gets much slower if this range is large. My range is very
> large, could be from
> 0 to 1000000000000.

you can use the program I posted at
http://www.standards.com/index.html?Sorting to compare timings.

Your best bet may be QuickSort,

[Michael C]

<bart.smissaert@gmail.com> wrote in message
news:1151397494.377543.103000@m73g2000cwd.googlegroups.com...
> Yes, had a quick look at the source and saw some functions without code

That's an interface, it's the fastest way to call a function in a class
without having to know all the details of the class before hand.

Michael