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 DatePrivate 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 SubPrivate 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 SubPublic 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, inHiEnd SubPublic 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, inHiEnd SubPrivate Function DateToJulian(MyDate As Date) As Long 'Return a numeric value representing 'the passed date DateToJulian = DateValue(MyDate)End Function
