Sorting Date Arrays using QuickSort

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