[VBnet Sort] Pure VB: Sorting Date Arrays using QuickSort


	Visual Basic Sort Routine Library Pure VB: Sorting Date Arrays using QuickSort

Posted:	Tuesday November 26, 2002
Updated:	Monday December 26, 2011

Applies to:	VB3, VB4-16, VB4-32, VB5, VB6
Developed with:	VB6, Windows NT4
OS restrictions:	None
Author:	VBnet - Randy Birch

Related:	Pure VB: Quick, Shell, Bubble and Selection Sort Performance Comparisons Pure VB: QuickSort Variations Pure VB: Sorting Date Arrays using QuickSort Pure VB: Applying and Understanding the QuickSort

Prerequisites

None.

This demo shows how to use VB's DateValue function to determine the days between dates in order to perform an ascending or descending sort of the data using a modified QuickSort method. The DateValue methods replaces the older DateDiff method that were previously posted on this page.

In the form Load event, the demo code's date are set up using VB's date literals. Regardless of how you enter literal dates, VB always changes the literals to use the literal date format of #MM/dd/yyyy#.

Following sorting, the results added to the list are always displayed using the Regional Setting's Short Date format. On my machine, this format is "yyyy MM dd", thus the member of "main interest" in determining success of the sort is the "middle" month member. By comparing that, then the year, you will see the dates are properly sorted by years, then months, and finally by date in the month.

The red lines on the image over the output list boxes were added to make the differentiation between years more discernable in the illustration.

BAS Module Code

None.

Form Code

To a form add three list boxes (List1-List3) and a command button (Command1). Labels are optional. Add the following code:

Option Explicit

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Copyright ©1996-2011 VBnet/Randy Birch, All Rights Reserved.
' Some pages may also contain other copyrights by the author.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Distribution: You can freely use this code in your own
'               applications, but you may not reproduce 
'               or publish this code on any web site,
'               online service, or distribute as source 
'               on any media without express permission.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Dim data() As Date

Private Sub Form_Load()

   Dim cnt As Long
   ReDim data(0 To 15) As Date
  
  'VB's literal date format
  'is month/day/year
   data(0) = #12/25/2001#
   data(1) = #2/1/1999#
   data(2) = #1/1/2000#
   data(3) = #3/19/2001#
   data(4) = #1/6/2000#
   data(5) = #1/3/2000#
   data(6) = #1/3/2002#
   data(7) = #3/30/2002#
   data(8) = #1/15/2002#
   data(9) = #7/7/2001#
   data(10) = #3/5/1998#
   data(11) = #4/9/2002#
   data(12) = #2/28/2000#
   data(13) = #1/12/2002#
   data(14) = #4/1/1998#
   data(15) = #10/5/1999#
  
  'show orig data
   For cnt = LBound(data) To UBound(data)
      List1.AddItem data(cnt)
   Next
     
   Command1.Caption = "Sort Dates"
   
End Sub


Private Sub Command1_Click()

   Dim x() As Date
   Dim cnt As Long
   
  'make a copy to preserve
  'original data
   x = data
   
   QuickSortDatesAscending x, LBound(x), UBound(x)
   
  'show sorted data
   For cnt = LBound(x) To UBound(x)
      List2.AddItem x(cnt)
   Next
   

  'reset and sort descending
   x = data
   
   QuickSortDatesDescending x, LBound(x), UBound(x)
   
  'show sorted data
   For cnt = LBound(x) To UBound(x)
      List3.AddItem x(cnt)
   Next
   
End Sub


Public Sub QuickSortDatesDescending(narray() As Date, inLow As Long, inHi As Long)

   Dim pivot As Long
   Dim tmpSwap As Long
   Dim tmpLow As Long
   Dim tmpHi  As Long
   
   tmpLow = inLow
   tmpHi = inHi
   
   pivot = DateToJulian(narray((inLow + inHi) / 2))
   
   While (tmpLow <= tmpHi)
        
      While DateToJulian(narray(tmpLow)) > pivot And (tmpLow < inHi)
         tmpLow = tmpLow + 1
      Wend
      
      While (pivot > DateToJulian(narray(tmpHi))) And (tmpHi > inLow)
         tmpHi = tmpHi - 1
      Wend
      
      If (tmpLow <= tmpHi) Then
         tmpSwap = narray(tmpLow)
         narray(tmpLow) = narray(tmpHi)
         narray(tmpHi) = tmpSwap
         tmpLow = tmpLow + 1
         tmpHi = tmpHi - 1
      End If
      
   Wend
    
   If (inLow < tmpHi) Then QuickSortDatesDescending narray(), inLow, tmpHi
   If (tmpLow < inHi) Then QuickSortDatesDescending narray(), tmpLow, inHi

End Sub


Public Sub QuickSortDatesAscending(narray() As Date, inLow As Long, inHi As Long)

   Dim pivot As Long
   Dim tmpSwap As Long
   Dim tmpLow As Long
   Dim tmpHi  As Long
   
   tmpLow = inLow
   tmpHi = inHi
   
   pivot = DateToJulian(narray((inLow + inHi) / 2))

   While (tmpLow <= tmpHi)
       
      While (DateToJulian(narray(tmpLow)) < pivot) And (tmpLow < inHi)
         tmpLow = tmpLow + 1
      Wend
   
      While (pivot < DateToJulian(narray(tmpHi))) And (tmpHi > inLow)
         tmpHi = tmpHi - 1
      Wend

      If (tmpLow <= tmpHi) Then
      
         tmpSwap = narray(tmpLow)
         narray(tmpLow) = narray(tmpHi)
         narray(tmpHi) = tmpSwap
         tmpLow = tmpLow + 1
         tmpHi = tmpHi - 1
         
      End If
      
   Wend
    
   If (inLow < tmpHi) Then QuickSortDatesAscending narray(), inLow, tmpHi
   If (tmpLow < inHi) Then QuickSortDatesAscending narray(), tmpLow, inHi

End Sub


Private Function DateToJulian(MyDate As Date) As Long

  'Return a numeric value representing
  'the passed date
   DateToJulian = DateValue(MyDate)

End Function

Comments

PayPal Link