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