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