Login | Register   
LinkedIn
Google+
Twitter
RSS Feed
Download our iPhone app
TODAY'S HEADLINES  |   ARTICLE ARCHIVE  |   FORUMS  |   TIP BANK
Browse DevX
Sign up for e-mail newsletters from DevX


Tip of the Day
Language: VB4,VB5,VB6,VBS
Expertise: Intermediate
Jul 29, 2000

CombSort - A very efficient algorithm

' Comb Sort an array of any type
'
' CombSort is faster than all but QuickSort and close to it.
' On the other hand, the code is much simpler than QuickSort
' and can be easily customized for any array type
' This routine is based on an article appeared on the Byte
' magazine in about 1985.
'
' NUMELS is the index of the last item to be sorted, and is
' useful if the array is only partially filled.
'
' Works with any kind of array, except UDTs and fixed-length
' strings, and including objects if your are sorting on their
' default property. String are sorted in case-sensitive mode.
'
' You can write faster procedures if you modify the first two lines
' to account for a specific data type, eg.
' Sub CombSortS(arr() As Single, Optional numEls As Variant,
'  Optional descending As Boolean)
'   Dim value As Single

Sub CombSort(arr As Variant, Optional numEls As Variant, _
    Optional Descending As Boolean)
    Dim value As Variant
    Dim index As Long
    Dim firstItem As Long
    Dim Gap As Long
    Dim Swap As Boolean

    ' account for optional arguments
    If IsMissing(numEls) Then numEls = UBound(arr)
    firstItem = LBound(arr)

    Gap = numEls - firstItem + 1
    Swap = False

    Do While (Gap > 1 Or Swap)
        ' divide Gap by 1.3 - the author says it's an empirical value
        If Gap > 1 Then Gap = (10 * Gap) \ 13
        ' another empirical value
        If (Gap = 9 Or Gap = 10) Then Gap = 11
        Swap = False
        For index = firstItem To numEls - Gap
            value = arr(index)
            If (value > arr(index + Gap)) Xor Descending Then
                ' if the items are not in order, swap them
                arr(index) = arr(index + Gap)
                arr(index + Gap) = value
                Swap = True
            End If
        Next
    Loop
End Sub
Paul Wolff
 
Comment and Contribute

 

 

 

 

 


(Maximum characters: 1200). You have 1200 characters left.

 

 

Sitemap
Thanks for your registration, follow us on our social networks to keep up-to-date