Tri de tableaux de string ou de chaines de tokens selon ordre et type

[philben]

bonjour,

ces fonctions permettent de Trier des tableaux de string ou des chaines de tokens selon un ordre et un type de donnée.

 
'---------------------------------------------------------------------------------------
' Projet     : Tri de tableaux de string ou de chaines de tokens selon ordre et type
' Création   : Le mercredi 22 août 2007
' Auteur     : P.B. [Philben]
'---------------------------------------------------------------------------------------
Option Compare Database
Option Explicit
' Types de tri autorisés
Public Enum eTypeTri
   eTexte
   eBinTexte
   eEntier
   eReel
   eDate
   eLongueur
   eBooléen
End Enum
Public Enum eOrdreTri
   eCroissant
   eDecroissant
End Enum
'---------------------------------------------------------------------------------------
' Procédure    : TriChaine [Function]
' Retour       : Variant
' Version      : 1.0
' Auteur       : P.B. [Philben]
' Création/Maj : Le mercredi 22 août 2007 à 01:58
' Objet        : Trier une chaine de tokens composée ou non de sous-tokens selon
'              : un ordre choisi et un type de token (texte, entier, réel, date,...)
' Historique   :
'---------------------------------------------------------------------------------------
Public Function TriChaine(ByVal vChaine As Variant, _
                          ByVal sSep As String, _
                          Optional ByVal eType As eTypeTri = eTypeTri.eTexte, _
                          Optional ByVal eOrdre As eOrdreTri = eOrdreTri.eCroissant, _
                          Optional ByVal bNoMoveFirst As Boolean = False, _
                          Optional ByVal iNbColonnes As Integer = 0, _
                          Optional ByVal sSepColonnes As String, _
                          Optional ByVal iNumColonneTri As Integer = 0, _
                          Optional ByRef bIsErreur As Boolean) _
                          As Variant
   Dim asTab() As String
   Dim sDeb As String, sFin As String, sTmpSep As String
   Dim lDeb As Long, lLenChaine As Long, lTmpPos As Long, lUb As Long
   Dim iLenSep As Integer, i As Integer, j As Integer, iCountCol As Integer
   bIsErreur = False
   If Nz(Len(vChaine)) > 1 And Len(sSep) Then
      If Left$(sSep, 1) <> " " Then vChaine = LTrim(vChaine)
      If Right$(sSep, 1) <> " " Then vChaine = RTrim(vChaine)
      lDeb = 1
      lLenChaine = Len(vChaine)
      iLenSep = Len(sSep)
      If Left(vChaine, iLenSep) = sSep Then
         lDeb = iLenSep + 1
         sDeb = sSep
      End If
      If Right(vChaine, iLenSep) = sSep Then
         lLenChaine = lLenChaine - lDeb - iLenSep + 1
         sFin = sSep
      End If
      If eType = eTypeTri.eReel And (sSep = "." Or sSep = ",") Then bIsErreur = True
      If iNbColonnes > 1 Then
         If iNumColonneTri < 1 Or iNumColonneTri > iNbColonnes Or _
            Len(sSepColonnes) = 0 Then
            bIsErreur = True
         Else
            If sSep = sSepColonnes Then
               i = 123
               Do
                  For j = 123 To 255
                     sSepColonnes = sTmpSep & Chr(j)
                     If InStr(lDeb, vChaine, sSepColonnes) = 0 Then Exit For
                  Next j
                  If j > 255 Then
                     If Len(sSepColonnes) > 3 Then
                        bIsErreur = True
                     Else
                        sTmpSep = Left$(sSepColonnes, Len(sSepColonnes) - 1) & Chr(j)
                        i = IIf(i = 255, 123, i + 1)
                     End If
                  End If
               Loop While j > 255 And Not bIsErreur
               If Not bIsErreur Then
                  lTmpPos = lDeb
                  iCountCol = 0
                  lTmpPos = InStr(lTmpPos, vChaine, sSep)
                  While lTmpPos > 0
                     iCountCol = iCountCol + 1
                     If iCountCol = iNbColonnes Then
                        vChaine = Left(vChaine, lTmpPos - 1) & _
                                  Replace(vChaine, sSep, sSepColonnes, lTmpPos, 1)
                        iCountCol = 0
                     End If
                     lTmpPos = InStr(lTmpPos + 1, vChaine, sSep)
                  Wend
                  sTmpSep = sSep
                  sSep = sSepColonnes
                  sSepColonnes = sTmpSep
               End If
            End If
         End If
      Else
         sSepColonnes = sSep
      End If
      If bNoMoveFirst Then
         lTmpPos = InStr(lDeb, vChaine, sSep)
         If lTmpPos Then
            lDeb = lTmpPos + iLenSep
            lLenChaine = lLenChaine - lDeb + 1
            sDeb = Left(vChaine, lDeb - 2) & sSepColonnes
         End If
      End If
      If lLenChaine > lDeb And Not bIsErreur Then
         asTab = Split(Mid(vChaine, lDeb, lLenChaine), sSep)
         lUb = UBound(asTab)
         If lUb > 0 Then
            If iNbColonnes <= 1 Then
               UnivTriTableau asTab, eType, eOrdre, 0, lUb
            ElseIf (UBound(asTab) + 1) Mod iNbColonnes = 0 Then
               UnivTriTableauCol asTab, eType, eOrdre, , , iNumColonneTri, sSepColonnes
            Else
               bIsErreur = True
            End If
         End If
         vChaine = sDeb & Join(asTab, sSepColonnes) & sFin
      End If
   Else
      bIsErreur = True
   End If
   TriChaine = vChaine
End Function
'---------------------------------------------------------------------------------------
' Procédure    : UnivTriTableau  [Sub]
' Retour       :
' Version      : 1.0
' Auteur       : P.B. [Philben]
' Création/Maj : Le mercredi 22 août 2007 à 02:05
' Objet        : Tri complétement ou partiellement un tableau de string selon
'              : un ordre choisi et un type de donnée (texte, entier, réel, date,...)
'              : Tri Shell ayant un bon rapport poids/performance
' Historique   :
'---------------------------------------------------------------------------------------
Public Sub UnivTriTableau(ByRef asTab() As String, _
                          ByVal eType As eTypeTri, _
                          ByVal eOrdre As eOrdreTri, _
                          Optional ByVal lLowerBound As Long = -1, _
                          Optional ByVal lUpperBound As Long = -1)
   Dim i As Long, j As Long, lInc As Long, n As Long, lMin As Long
   Dim vConvRef As Variant
   Dim sRef As String
   If lLowerBound = -1 Then lLowerBound = LBound(asTab)
   If lUpperBound = -1 Then lUpperBound = UBound(asTab)
   n = lUpperBound - lLowerBound + 1
   lInc = 1
   While lInc < n
      lInc = lInc * 3 + 1
   Wend
   While lInc > 1
      lInc = lInc / 3
      lMin = lInc + lLowerBound
      For i = lMin To lUpperBound
         j = i
         sRef = asTab(i)
         vConvRef = UTTConversion(sRef, eType)
         Do While UTTCompare(vConvRef, UTTConversion(asTab(j - lInc), eType), eOrdre, eType)
            asTab(j) = asTab(j - lInc)
            j = j - lInc
            If j < lMin Then Exit Do
         Loop
         asTab(j) = sRef
      Next i
   Wend
End Sub
'---------------------------------------------------------------------------------------
' Procédure    : UnivTriTableauCol  [Sub]
' Retour       :
' Version      : 1.0
' Auteur       : P.B. [Philben]
' Création/Maj : Le mercredi 22 août 2007 à 02:05
' Objet        : Tri complétement ou partiellement un tableau de string selon
'              : un ordre choisi et un type de token (texte, entier, réel, date,...)
'              : Permet de trier un tableau selon un numéro de sous-token choisi
'              : Version plus polyvalente mais 3 fois moins rapide
' Historique   :
'---------------------------------------------------------------------------------------
Public Sub UnivTriTableauCol(ByRef asTab() As String, _
                             ByVal eType As eTypeTri, _
                             ByVal eOrdre As eOrdreTri, _
                             Optional ByVal lLowerBound As Long = -1, _
                             Optional ByVal lUpperBound As Long = -1, _
                             Optional ByVal iNumColTri As Integer = 0, _
                             Optional ByVal sSepColonnes As String)
   Dim i As Long, j As Long, lInc As Long, n As Long, lMin As Long
   Dim vConvRef As Variant, vConvCur As Variant
   Dim sRef As String
   If lLowerBound = -1 Then lLowerBound = LBound(asTab)
   If lUpperBound = -1 Then lUpperBound = UBound(asTab)
   If iNumColTri > 0 Then iNumColTri = iNumColTri - 1
   n = lUpperBound - lLowerBound + 1
   lInc = 1
   While lInc < n
      lInc = lInc * 3 + 1
   Wend
   While lInc > 1
      lInc = lInc / 3
      lMin = lInc + lLowerBound
      For i = lMin To lUpperBound
         j = i
         sRef = asTab(i)
         If iNumColTri = -1 Then
            vConvRef = UTTConversion(sRef, eType)
            vConvCur = UTTConversion(asTab(j - lInc), eType)
         Else
            vConvRef = UTTConversion(Split(sRef, sSepColonnes)(iNumColTri), eType)
            vConvCur = UTTConversion(Split(asTab(j - lInc), sSepColonnes)(iNumColTri), eType)
         End If
         Do While UTTCompare(vConvRef, vConvCur, eOrdre, eType)
            asTab(j) = asTab(j - lInc)
            j = j - lInc
            If j < lMin Then
               Exit Do
            ElseIf iNumColTri = -1 Then
               vConvCur = UTTConversion(asTab(j - lInc), eType)
            Else
               vConvCur = UTTConversion(Split(asTab(j - lInc), sSepColonnes)(iNumColTri), eType)
            End If
         Loop
         asTab(j) = sRef
      Next i
   Wend
End Sub
'---------------------------------------------------------------------------------------
' Procédure    : UTTConversion   [Function]
' Retour       : Variant
' Version      : 1.0
' Création/Maj : Le mercredi 22 août 2007 à 02:29
' Objet        : Fonction appelée par UnivTriTableau... pour convertir les données
' Historique   :
'---------------------------------------------------------------------------------------
Private Function UTTConversion(ByVal v As String, ByVal eType As eTypeTri) As Variant
   If eType = eTypeTri.eTexte Or eType = eTypeTri.eBinTexte Then
      UTTConversion = v
   ElseIf Len(v) = 0 Then
      UTTConversion = 0
   Else
      Select Case eType
      Case eTypeTri.eEntier
         UTTConversion = CLng(v)
      Case eTypeTri.eReel
         If InStr(v, ",") Then
            UTTConversion = Val(Replace(v, ",", ".", , 1))
         Else
            UTTConversion = Val(v)
         End If
      Case eTypeTri.eDate
         UTTConversion = DateValue(v)
      Case eTypeTri.eBooléen
         UTTConversion = CBool(v)
      Case eTypeTri.eLongueur
         UTTConversion = Len(v)
      End Select
   End If
End Function
'---------------------------------------------------------------------------------------
' Procédure    : UTTCompare   [Function]
' Retour       : Boolean
' Version      : 1.0
' Création/Maj : Le mercredi 22 août 2007 à 02:29
' Objet        : Fonction appelée par UnivTriTableau... pour comparer les valeurs
' Historique   :
'---------------------------------------------------------------------------------------
Private Function UTTCompare(ByVal v1 As Variant, ByVal v2 As Variant, _
                            ByVal eOrdre As eOrdreTri, ByVal eType As eTypeTri) As Boolean
   Select Case eType
   Case eTypeTri.eTexte
      UTTCompare = (StrComp(v1, v2, vbTextCompare) = -1 Eqv eOrdre = eOrdreTri.eCroissant)
   Case eTypeTri.eBinTexte
      UTTCompare = (StrComp(v1, v2, vbBinaryCompare) = -1 Eqv eOrdre = eOrdreTri.eCroissant)
   Case Else
      UTTCompare = (v1 < v2 Eqv eOrdre = eOrdreTri.eCroissant)
   End Select
End Function
 

Un jeu de test :

 
Public Sub TestTri()
   Dim s As Variant
   Dim i As Long, j As Long
   Dim t As Single
   Dim c As String
   Dim bIsErr As Boolean
   Dim ast(3 To 10) As String
   Randomize
Debug.Print "Tri décroissant partiel (dim 2,3,4) d'un tableau de string de booléen"
Debug.Print "---------------------------------------------------------------------"
   For i = LBound(ast) To UBound(ast)
      ast(i) = IIf(Rnd < 0.5, "vrai", "faux")
   Next i
   UnivTriTableau ast, eTypeTri.eBooléen, eOrdreTri.eDecroissant, 4, 6
   s = ""
   For i = LBound(ast) To UBound(ast)
      s = s & ast(i) & vbTab
   Next i
Debug.Print s
Debug.Print vbCrLf & "Performance du tri de texte (49 151 tokens)"
Debug.Print "--------------------------------------------"
   s = ""
   For i = 1 To 12
      s = s & Rnd & "|"
   Next i
   For i = 1 To 12
      s = s & s
   Next i
   t = Timer()
   s = TriChaine(s, "|", eTypeTri.eTexte, eOrdreTri.eCroissant)
Debug.Print vbTab & "Temps : " & (Timer() - t) & "sec", "Longueur chaine : " & Len(s)
Debug.Print vbTab & Left(s, 1000) & IIf(Len(s) > 1000, " ...", "")
   DoEvents
Debug.Print vbCrLf & "Tri croissant d'une chaine de texte"
Debug.Print "-----------------------------------"
   s = ""
   For i = 1 To 500
      s = s & Chr((122 - 48) * Rnd + 48) & "|"
   Next i
   t = Timer()
   s = TriChaine(s, "|", eTypeTri.eTexte, eOrdreTri.eCroissant)
Debug.Print vbTab & "Temps : " & (Timer() - t) & "sec", "Longueur chaine : " & Len(s)
Debug.Print vbTab & Left(s, 1000) & IIf(Len(s) > 1000, " ...", "")
Debug.Print vbCrLf & "Tri croissant d'une chaine de texte avec le premier token fixe"
Debug.Print "--------------------------------------------------------------"
   s = ""
   For i = 1 To 250
      s = s & Chr((122 - 48) * Rnd + 48) & "|"
   Next i
   s = "Toujours en premier|" & s
   t = Timer()
   s = TriChaine(s, "|", eTypeTri.eTexte, eOrdreTri.eCroissant, True)
Debug.Print vbTab & "Temps : " & (Timer() - t) & "sec", "Longueur chaine : " & Len(s)
Debug.Print vbTab & Left(s, 1000) & IIf(Len(s) > 1000, " ...", "")
Debug.Print vbCrLf & "Tri décroissant d'une chaine de texte (comparaison binaire)"
Debug.Print "-----------------------------------------------------------"
   s = ""
   For i = 1 To 500
      s = s & Chr((122 - 48) * Rnd + 48) & "|"
   Next i
   t = Timer()
   s = TriChaine(s, "|", eTypeTri.eBinTexte, eOrdreTri.eDecroissant)
Debug.Print vbTab & "Temps : " & (Timer() - t) & "sec", "Longueur chaine : " & Len(s)
Debug.Print vbTab & Left(s, 1000) & IIf(Len(s) > 1000, " ...", "")
Debug.Print vbCrLf & "Tri décroissant d'entiers"
Debug.Print "-------------------------"
   s = ""
   For i = 1 To 200
      s = s & Int(2000 * Rnd - 1000) & "|"
   Next i
   t = Timer()
   s = TriChaine(s, "|", eTypeTri.eEntier, eOrdreTri.eDecroissant)
Debug.Print vbTab & "Temps : " & (Timer() - t) & "sec", "Longueur chaine : " & Len(s)
Debug.Print vbTab & Left(s, 1000) & IIf(Len(s) > 1000, " ...", "")
   DoEvents
Debug.Print vbCrLf & "Tri croissant de réels (séparateur décimal : ,)"
Debug.Print "-----------------------------------------------"
   s = ""
   For i = 1 To 100
      s = s & (2000 * Rnd - 1000) & "|"
   Next i
   t = Timer()
   s = TriChaine(s, "|", eTypeTri.eReel, eOrdreTri.eCroissant)
Debug.Print vbTab & "Temps : " & (Timer() - t) & "sec", "Longueur chaine : " & Len(s)
Debug.Print vbTab & Left(s, 1000) & IIf(Len(s) > 1000, " ...", "")
Debug.Print vbCrLf & "Tri décroissant de réels (séparateur décimal : .)"
Debug.Print "-------------------------------------------------"
   s = ""
   For i = 1 To 100
      s = s & Replace((2000 * Rnd - 1000), ",", ".") & "|"
   Next i
   t = Timer()
   s = TriChaine(s, "|", eTypeTri.eReel, eOrdreTri.eDecroissant)
Debug.Print vbTab & "Temps : " & (Timer() - t) & "sec", "Longueur chaine : " & Len(s)
Debug.Print vbTab & Left(s, 1000) & IIf(Len(s) > 1000, " ...", "")
Debug.Print vbCrLf & "Tri croissant de dates"
Debug.Print "----------------------"
   s = ""
   For i = 1 To 75
      s = s & CDate(Date - i) & "|"
   Next i
   t = Timer()
   s = TriChaine(s, "|", eTypeTri.eDate, eOrdreTri.eCroissant)
Debug.Print vbTab & "Temps : " & (Timer() - t) & "sec", "Longueur chaine : " & Len(s)
Debug.Print vbTab & Left(s, 1000) & IIf(Len(s) > 1000, " ...", "")
   DoEvents
Debug.Print vbCrLf & "Tri décroissant de dates et heures"
Debug.Print "----------------------------------"
   s = ""
   For i = 1 To 50
      s = s & CDate(Now() - i) & "|"
   Next i
   t = Timer()
   s = TriChaine(s, "|", eTypeTri.eDate, eOrdreTri.eDecroissant)
Debug.Print vbTab & "Temps : " & (Timer() - t) & "sec", "Longueur chaine : " & Len(s)
Debug.Print vbTab & Left(s, 1000) & IIf(Len(s) > 1000, " ...", "")
Debug.Print vbCrLf & "Tri croissant selon la longueur des tokens"
Debug.Print "------------------------------------------"
   s = ""
   For i = 1 To 60
      c = ""
      For j = 0 To (Rnd * 25)
         c = c & Chr((122 - 48) * Rnd + 48)
      Next j
      s = s & c & "|"
   Next i
   t = Timer()
   s = TriChaine(s, "|", eTypeTri.eLongueur, eOrdreTri.eCroissant)
Debug.Print vbTab & "Temps : " & (Timer() - t) & "sec", "Longueur chaine : " & Len(s)
Debug.Print vbTab & Left(s, 1000) & IIf(Len(s) > 1000, " ...", "")
Debug.Print vbCrLf & "Tri croissant sur la deuxième colonne des tokens composés 3 colonnes "
Debug.Print "---------------------------------------------------------------------"
   s = ""
   For i = 1 To 450
      If (i + 1) Mod 3 = 0 Then
         s = s & Chr((90 - 65) * Rnd + 65) & "|"
      Else
         s = s & Chr((57 - 48) * Rnd + 48) & "|"
      End If
   Next i
   t = Timer()
   s = TriChaine(s, "|", eTypeTri.eBinTexte, eOrdreTri.eCroissant, , 3, "|", 2, bIsErr)
Debug.Print vbTab & "Temps : " & (Timer() - t) & "sec", "Longueur chaine : " & Len(s), "Erreur :" & bIsErr
Debug.Print vbTab & Left(s, 1000) & IIf(Len(s) > 1000, " ...", "")
End Sub
 

cordialement,

Philippe