Can this QuickSort work?

R

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
 
B

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)
 
R

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
 
R

RB Smissaert

Yes, tried in VB and exactly same faults.

RBS

Bob Phillips said:
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)
Click to expand...
 
R

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
 
R

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
 
R

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
 
B

Bob Phillips

ah, but it is faster <vbg>

RB Smissaert said:
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
Click to expand...
 
R

RB Smissaert

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

RBS
 
M

Michael C

RB Smissaert said:
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.
Click to expand...

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

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

Michael
 
H

Howard Kaikow

RB Smissaert said:
Well, I have the regular/standard QuickSort and that is pretty fast, but I
thought
this might be faster. Shame it doesn't sort.
Click to expand...

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

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
 
R

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
 
R

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
 
B

bart.smissaert

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
 
M

Michael C

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

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
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Bubble Sort failure, Strcomp with binary compare 9
Remove Identical words 0
Find the correct sheet then find a value on that sheet 8
Make VBA ComboBox_Change work in 3 sheets 1
Making a macro only work on certain files 2
Match style 0
Chart Title color can't be duplicated (also series color) 0
Where am I going wrong? Cells reference to a range appears to havestopped working! 5

Top