Sorting Date Arrays using QuickSort

最新推荐文章于 2022-03-24 15:24:57 发布

kendyhj9999

最新推荐文章于 2022-03-24 15:24:57 发布

阅读量423

点赞数

分类专栏： VB

VB 专栏收录该内容

4 篇文章

订阅专栏

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