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

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" wrote in message
...
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

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" wrote in message
...
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" wrote in message
...
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

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" wrote in message
...
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" wrote in message
...
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" wrote in message
...
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

Yes, tried in VB and exactly same faults.

RBS

"Bob Phillips" wrote in message
...
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" wrote in message
...
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

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

Bob

"RB Smissaert" wrote in message
...
Yes, tried in VB and exactly same faults.

RBS

"Bob Phillips" wrote in message
...
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" wrote in message
...
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

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" wrote in message
...
I am not surprised, as it didn't seem to use anything particularly VBA.

Bob

"RB Smissaert" wrote in message
...
Yes, tried in VB and exactly same faults.

RBS

"Bob Phillips" wrote in message
...
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" wrote in message
...
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

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

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" wrote in message
...
See http://www.standards.com/index.html?Sorting for a bunch of algorithms
that work.

ah, but it is faster <vbg

"RB Smissaert" wrote in message
...
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" wrote in message
...
See http://www.standards.com/index.html?Sorting for a bunch of
algorithms
that work.

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

RBS

"Bob Phillips" wrote in message
...
ah, but it is faster <vbg

"RB Smissaert" wrote in message
...
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" wrote in message
...
See http://www.standards.com/index.html?Sorting for a bunch of
algorithms
that work.

LOL!

"RB Smissaert" wrote in message
...
If being fast was the main thing I could make it much faster and simpler
at
the same time :)

RBS

"Bob Phillips" wrote in message
...
ah, but it is faster <vbg

"RB Smissaert" wrote in message
...
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" wrote in message
...
See http://www.standards.com/index.html?Sorting for a bunch of
algorithms
that work.

"RB Smissaert" wrote in message
...
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.

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" wrote in message
...
"RB Smissaert" wrote in message
...
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" wrote in message
...
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" wrote in message
...
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

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" wrote in message
...
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