Tri d'un tableau par la méthode "Shell"

[Michael DELIQUE]

Code : Tout sélectionner

Sub SortShell(vrTable As Variant)

   'Tri par shell par ordre croissant
   
   'Déclaration Variables
   Dim nbUbound As Long
   Dim nbLbound As Long
   Dim nbGap As Long
   Dim i As Long
   Dim J As Long
   Dim vrValue As Variant
   
   On Error Goto ErreurHandle
   
   nbLbound = Lbound(vrTable)
   nbUBound = Ubound(vrTable)
   
   If nbUBound = nbLbound Then
      'si 1 seule donnée 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   
   
   nbGap = nbLbound
   Do
      nbGap = (3 * nbGap) + 1
   Loop Until nbGap > nbUbound
   
   Do
      nbGap = nbGap \ 3
      For i = nbGap + nbLbound To nbUbound
         vrValue = vrTable( i )
         J = i - nbGap
         Do While (vrTable(J) > vrValue)
            vrTable( J + nbGap ) = vrTable( J )
            J = J - nbGap
            If J < nbLbound Then
               Exit Do
            End If   
         Loop
         vrTable( J + nbGap ) = vrValue
         vrValue = Null
      Next
   Loop Until nbGap = 1
   
   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