Tri d'un tableau par la methode "par Tas"

[Michael DELIQUE]

Code : Tout sélectionner

Sub SortHeap(vrTable As Variant)
   
   'Tri par "Tas/Heap" par ordre croissant
   
   'Déclaration Variables
   Dim nbUBound As Long
   Dim nbLBound As Long
   Dim nbHigh As Long
   Dim i As Long
   Dim j As Long
   Dim k As Long
   Dim vrValue As Variant
   
   On Error Goto ErreurHandle
   
   nbLbound = Lbound(vrTable)
   nbUBound = Ubound(vrTable)
   
   If nbUBound = nbLbound Then
      'si 1 seul donné pas de traitement
      Exit Sub
   Elseif nbUBound = (nbLbound+1) Then
      'si uniquement 2 données
      If  vrTable(nbLbound) >  vrTable(nbUBound) Then
         vrValue = vrTable(nbUBound)
         vrTable(nbUBound) = vrTable(nbLbound)
         vrTable(nbLbound) = vrValue
         vrValue = Null
      End If
      Exit Sub
   End If   
   
   nbHigh = nbUBound
   For i = nbUBound \ 2 To nbLBound Step -1
      k = i
      vrValue = vrTable( k )
      Do While k <= nbUBound \ 2
         j = k + k
         If j < nbUBound Then
            If  vrTable( j ) < vrTable( j + 1 )  Then
               j = j + 1
            End If
         End If
         If vrValue >= vrTable( j ) Then
            Exit Do
         End If
         vrTable( k ) = vrTable( j )
         k = j
      Loop
      vrTable( k ) = vrValue
   Next
   Do
      vrValue = vrTable(nbLBound)
      vrTable(nbLBound) = vrTable(nbHigh)
      vrTable(nbHigh) = vrValue
      vrValue = Null
      nbHigh = nbHigh - 1
      k = nbLBound
      vrValue = vrTable( k )
      Do While k <= nbHigh \ 2
         j = k + k
         If j < nbHigh Then
            If  vrTable( j ) < vrTable( j + 1 ) Then
               j = j + 1
            End If
         End If
         If  vrValue >= vrTable( j ) Then
            Exit Do
         End If
         vrTable( k ) = vrTable( j )
         k = j
      Loop
      vrTable( k ) = vrValue
   Loop Until nbHigh = nbLBound
   
   Exit Sub
ErreurHandle:
   Msgbox "("+Cstr(Getthreadinfo (1))+" Call by "+Cstr(Getthreadinfo(10))+")"+Chr(10)+"Erreur " + Str(Err) + " : "+Chr(10) + Cstr(Error)+". "+Chr(10)+"Ligne N° "+Cstr(Erl),16," ERREUR !"
   Exit Sub
End Sub