Simple Descend Sorting in Visual Basic

Simple Descend Sorting

in Visual Basic®

by Rick Meyer Home

Other Sorting Pages
Simple Ascend Sorting
Simple Bi_Direction Sorting
Sorting Viewer
Sorting Timer

Below you will find simplified procedures for sorting in descending order with:

Bubble Sort

BiBubble Sort

Insertion Sort

Shell Sort

Selection Sort

BiSelection Sort

Quick Sort

Heap Sort

These procedures have been incorporated into a project so that you can watch and experiment with them. Use the following instructions to construct the project or just copy the specific procedures that you want.

For commented code see simple ascend link above. The comments in the code below just indicate lines that differ from the ascend page code.

Instructions for Building this Project:

1. Start a new standard exe.
2. On Form1 put a CommandButton named Command1.
3. On Form1 put a CommandButton named Command2.
4. Set the Command1.Index property to 0.
5. Vary the MIN and MAX constants as desired.

There is no need to position or size the above controls
on the form since that is all done in the Form_Load.

Now you are ready for the code. Select all of the following code (by clicking on the word 'Option' three times) and copy it to the clipboard [Ctrl][Insert]. Then paste it into the code window of Form1 with [Shift][Insert].

Variable Key
% As Integer
& As Long
! As Single
# As Double
$ As String

Option Explicit

Const MIN = 21, MAX = 30

Private Enum sortType
    BUBBLE
    BIBUBBLE
    INSERTION
    SHELLS
    SELECTION
    BISELECTION
    QUICK
    HEAP
End Enum

Dim Last1%
Dim sortarray() As Integer

Private Sub Bubble_Sort()
    Dim j%, last%, tmp%, Done As Boolean
    
    last = Last1 - 1
    
    Do While Not Done
        Done = True
        
        For j = 0 To last
            'Just this line is changed
            If sortarray(j) < sortarray(j + 1) Then
                tmp = sortarray(j)
                sortarray(j) = sortarray(j + 1)
                sortarray(j + 1) = tmp
                
                Done = False
            End If
        Next
        
        last = last - 1
    Loop
End Sub


Private Sub BiBubble_Sort()
    Dim j%, first%, last%, tmp%, Done As Boolean
        
    last = Last1 - 1
    Do While Not Done
        Done = True
        For j = first To last
            'This line is changed
            If sortarray(j) < sortarray(j + 1) Then
                tmp = sortarray(j)
                sortarray(j) = sortarray(j + 1)
                sortarray(j + 1) = tmp
                Done = False
            End If
        Next
        
        If Done Then Exit Do
        first = first + 1
        
        For j = last To first Step -1
            'This line is changed
            If sortarray(j) > sortarray(j - 1) Then
                tmp = sortarray(j)
                sortarray(j) = sortarray(j - 1)
                sortarray(j - 1) = tmp
                Done = False
            End If
        Next
        
        last = last - 1
    Loop
End Sub

Private Sub Insertion_Sort()
    Dim j%, low%, high%, tmp%
    
    For j = 1 To Last1
        high = j
        Do
            low = high - 1
            'This line is changed
            If sortarray(low) < sortarray(high) Then
                tmp = sortarray(low)
                sortarray(low) = sortarray(high)
                sortarray(high) = tmp
                
                high = low
            Else
                Exit Do
            End If
        Loop Until high <= 0
    Next
End Sub

Private Sub Insertion_Shuffle_Sort()
    Dim j%, low%, high%, tmp%
    
    For j = 1 To Last1
        high = j
        tmp = sortarray(high)

        Do
            low = high - 1
            'This line is changed
            If sortarray(low) >= tmp Then Exit Do
            sortarray(high) = sortarray(low)
            high = low
        Loop Until high <= 0

        sortarray(high) = tmp
    Next
End Sub

Private Sub Shell_Sort()
    Dim diff%, low%, high%, tmp%
    
    diff = Last1 \ 2
    
    Do While diff
        high = diff
        
        Do Until high > Last1
            low = high - diff
            'This line is changed
            If sortarray(low) < sortarray(high) Then
                tmp = sortarray(low)
                sortarray(low) = sortarray(high)
                sortarray(high) = tmp
                
                If diff = 1 Then
                    If low > 0 Then high = low - 1
                End If
            End If
            
            high = high + 1
        Loop
        
        diff = Int(CSng(diff) / 1.3)
    Loop
End Sub

Private Sub Selection_Sort()
    Dim j%, tmp%, low%, lower%
    
    Do Until lower >= Last1
        low = lower
                
        For j = lower + 1 To Last1
            'This line is changed
            If sortarray(j) > sortarray(low) Then low = j
        Next
        
        If low <> lower Then
            tmp = sortarray(lower)
            sortarray(lower) = sortarray(low)
            sortarray(low) = tmp
        End If
        
        lower = lower + 1
    Loop
End Sub

Private Sub BiSelection_Sort()
    Dim j%, low%, high%, lower%, upper%, tmp%
    
    upper = Last1
    
    Do Until lower >= upper
        high = upper
        low = lower
                
        For j = lower To upper
            'This line is changed
            If sortarray(j) > sortarray(low) Then
                low = j
            'This line is changed
            ElseIf sortarray(j) < sortarray(high) Then
                high = j
            End If
        Next
        
        If high <> upper Then
            If low = upper Then low = high
            tmp = sortarray(upper)
            sortarray(upper) = sortarray(high)
            sortarray(high) = tmp
        End If
        
        If low <> lower Then
            tmp = sortarray(lower)
            sortarray(lower) = sortarray(low)
            sortarray(low) = tmp
        End If
        
        lower = lower + 1
        upper = upper - 1
    Loop
End Sub

Private Sub Quick_Sort(ByVal lower%, ByVal upper%)
    If lower >= upper Then Exit Sub
    
    Dim low%, midl%, high%, midval%, tmp%
    
    low = lower
    high = upper
    
    midl = lower + (upper - lower) \ 2
    midval = sortarray(midl)
 
    Do While low <= high
        Do Until low >= upper
            'This line is changed
            If sortarray(low) <= midval Then Exit Do
            low = low + 1
        Loop
     
        Do Until high <= lower
            'This line is changed
            If midval <= sortarray(high) Then Exit Do
            high = high - 1
        Loop
 
        If low <= high Then
            If low < high Then
                tmp = sortarray(low)
                sortarray(low) = sortarray(high)
                sortarray(high) = tmp
            End If
            low = low + 1
            high = high - 1
        End If
    Loop

    If lower < high Then Quick_Sort lower, high
    If low < upper Then Quick_Sort low, upper
End Sub

Private Sub Heap_Sort()
    Dim j%, tmp%

    j = Last1 - Last1 \ 2
    
    Do Until j >= Last1
        SiftUp Last1, j, 0
        j = j + 1
    Loop

    For j = 0 To Last1 - 1
        'This line is changed
        If sortarray(Last1) > sortarray(j) Then
            tmp = sortarray(Last1)
            sortarray(Last1) = sortarray(j)
            sortarray(j) = tmp
            
            SiftUp Last1, Last1 - 1, j
        End If
    Next
End Sub
Private Sub SiftUp(first%, ByVal midl%, last%)
    Dim k%, k1%, m1%, tmp%
    
    k = (midl - first) * 2 + first
    Do While k >= last
        If k > last Then
            k1 = k + 1
            'This line is changed
            If sortarray(k) > sortarray(k1) Then
                k = k - 1
            End If
        End If
        
        k1 = k + 1
        m1 = midl + 1
        'This line is changed
        If sortarray(k1) > sortarray(m1) Then
            tmp = sortarray(k1)
            sortarray(k1) = sortarray(m1)
            sortarray(m1) = tmp
        Else
            Exit Do
        End If
        midl = k
        k = (midl - first) * 2 + first
    Loop
End Sub

Private Sub Command1_Click(Index As Integer)
    Caption = Command1(Index).Caption
    
    Select Case Index
        Case BUBBLE: Bubble_Sort
        Case BIBUBBLE: BiBubble_Sort
        Case SHELLS: Shell_Sort
        Case INSERTION: Insertion_Sort
        Case SELECTION: Selection_Sort
        Case BISELECTION: BiSelection_Sort
        Case QUICK: Quick_Sort 0, Last1
        Case HEAP: Heap_Sort
    End Select
    
    ShowArray
End Sub

Private Sub Command2_Click()
    Dim j%, k%
    Dim c As New Collection
    
    Randomize
    Last1 = MAX - MIN
    ReDim sortarray(Last1)
    
    For j = MIN To MAX
        c.Add j
    Next
    
    Do While c.Count > 0
        j = Int(c.Count * Rnd) + 1
        sortarray(k) = CInt(c.Item(j))
        c.Remove j
        k = k + 1
    Loop
    
    Caption = "Descend Sorting"
    ShowArray
End Sub

Private Sub ShowArray()
    Dim j%
    
    Cls
    For j = 0 To Last1
         Print sortarray(j)
    Next
End Sub

Private Sub Form_Load()
    Const MARGIN = 200, HGHT = 300, WDTH = 1600
    Dim j%, lt!, tp!
    
    Move 1000, 1000, 4800, 3600
    tp = MARGIN
    lt = Width - (WDTH + MARGIN) * 2
    
    For j = 0 To 7
        If j Then Load Command1(j)
        
        With Command1(j)
            .Move lt, tp, WDTH, HGHT
            .FontBold = True
            Select Case j
                Case BUBBLE: .Caption = "Bubble Sort"
                Case BIBUBBLE: .Caption = "BiBubble Sort"
                Case INSERTION: .Caption = "Insertion Sort"
                Case SHELLS: .Caption = "Shell Sort"
                Case SELECTION: .Caption = "Selection Sort"
                Case BISELECTION: .Caption = "BiSelection Sort"
                Case QUICK: .Caption = "Quick Sort"
                Case HEAP: .Caption = "Heap Sort"
            End Select
            .Visible = True
        End With
        
        If j = 3 Then
            lt = lt + MARGIN + WDTH
            tp = MARGIN
        Else
            tp = tp + HGHT + MARGIN
        End If
    Next
    
    lt = lt - MARGIN - WDTH
    With Command2
        .Move lt, tp, WDTH * 2 + MARGIN, HGHT
        .FontBold = True
        .Caption = "Randomize"
    End With
    
    FontBold = True
    AutoRedraw = True
    Command2_Click
End Sub