Cette classe d'objet permet de trier un tableau à une ou deux dimensions sur une ou plusieurs colonnes
Source / Exemple :
Option Explicit
'Auteur : Florent Bénetière, tnerolf@lekod.com
'Cette classe d'objet permet de trier un tableau à une ou deux dimensions sur une ou plusieurs colonnes
'****************************************************************
'* !!CONTRAINTE !! *
'* Le contenu d'une "case" du tableau ne doit pas être Nul *
'* Les valeurs vides sont autorisées *
'****************************************************************
'****************************************************************
'* !! PRE REQUIS !! *
'* La bibliothèque Microsoft VBScript Regular Expressions 5.5 *
'* [Chemin vers Windows]\System32\vbscript.dll *
'****************************************************************
Private NbreLignes As Integer 'Nombre de lignes du tableau à trier
Private NbreColonnes As Byte 'Nombre de colonnes du tableau à trier
Private NbreDimensions As Byte 'Nombre de dimensions du tableau (1 ou 2)
Private TableauATrier As Variant 'Le tableau à trier
Private TblColonnesTri() As String 'Tableau contenant les numéros des colonnes du tableau sur lesquels
'effectuer un tri. Sa structure est TblColonnesTri[Numéro de colonne][Ordre de Tri]
'[Ordre de Tri] est soit "ASC" soit "DESC". S'il n'est pas renseigné, il prend la valeur "ASC"
Private TblFinal As Variant 'Tableau renseigné au fur et à mesure des tris sur les colonnes
Private PrecisionDecimal As Integer 'Détermine combien de décimales on doit afficher pour les nombres
Property Let AttribueTableau(Tableau As Variant)
Dim a As Integer, b As Integer
TableauATrier = Tableau
DetermineDimensions
'Si le tableau n'a qu'une seule dimension, on a pas besoin d'initialiser TblFinal car le tri
'TableauATrier ne s'appuiera pas sur TblFinal pour se faire
'On initialise TblFinal et on le remplit avec des "*"
'Cela permettra d'élaborer ultérieurement les motifs afin de respecter les ordres de tri
'en fonction des colonnes choisies
If NbreDimensions = 2 Then
ReDim TblFinal(NbreColonnes, NbreLignes)
For a = 0 To NbreLignes
For b = 0 To NbreColonnes
TblFinal(b, a) = "*"
Next b
Next a
End If
End Property
Property Get TableauTrie() As Variant
'Cette propriété renvoie le tableau TableauATrier une fois ce dernier
'trié par les colonnes et les sens de tri du tableau TblColonnesTri
Dim LigneTri As Integer, TailleTri As Integer, LigneTableau As Integer, Colonne As Byte
Dim TblColonne As Variant, Motif As String
If NbreDimensions = 1 Then
'Là, c'est facile, il n'y a qu'une colonne
TableauTrie = TriSurUneColonne(TableauATrier, TblColonnesTri(1, 0))
Exit Property
End If
TailleTri = UBound(TblColonnesTri, 2)
If TailleTri > 0 Then TailleTri = TailleTri - 1 '-1 car dernière colonne de TblColonnesTri est toujours vide
'On trie uniquement la colonne visée
'(1) On remplit TblColonne avec les valeurs contenues dans la colonne visée
'(2) On la trie
'(3) On renseigne TblFinal avec les valeurs de TblColonne
For LigneTri = 0 To TailleTri
ReDim TblColonne(NbreLignes)
'(1)
For LigneTableau = 0 To NbreLignes
TblColonne(LigneTableau) = TableauATrier(TblColonnesTri(0, LigneTri), LigneTableau)
Next LigneTableau
'(2)
TblColonne = TriSurUneColonne(TblColonne, TblColonnesTri(1, LigneTri))
For LigneTableau = 0 To NbreLignes
'(3)
RemplitTblFinal TblColonne(LigneTableau), CByte(TblColonnesTri(0, LigneTri))
Next LigneTableau
Next LigneTri
'Maintenant, on se charge de remplir toutes les cases non renseignées de TblFinal
'En parcourant TableauATrier et en élaborant les motifs
For LigneTableau = 0 To NbreLignes
CombleTblFinal LigneTableau
Next LigneTableau
TableauTrie = TblFinal
End Property
Property Let NbreDecimales(Decimales As Integer)
PrecisionDecimal = Abs(Decimales)
End Property
Property Get PrecisionDecimales()
NbreDecimales = PrecisionDecimal
End Property
Public Sub AjouteColonneTri(NumCol As Byte, Optional SensTri As String = "ASC")
'Cette procédure ajoute une colonne de tri au tableau TblColonnesTri
Dim Taille As Byte
Taille = UBound(TblColonnesTri, 2)
TblColonnesTri(0, Taille) = NumCol: TblColonnesTri(1, Taille) = IIf(SensTri <> "DESC", "ASC", "DESC")
ReDim Preserve TblColonnesTri(1, Taille + 1)
End Sub
Public Sub SupprimeColonneTri(NumCol As Byte)
'Cette procédure supprime du tableau TblColonnesTri la ligne correspondant à Numcol
Dim Ligne As Byte, Compteur As Byte, Taille As Byte, TblTemp() As String
Taille = UBound(TblColonnesTri, 2)
ReDim TblTemp(1, 0)
For Ligne = 0 To Taille
If TblColonnesTri(0, Ligne) <> vbNullString Then
If TblColonnesTri(0, Ligne) <> NumCol Then
TblTemp(0, Compteur) = TblColonnesTri(0, Ligne)
TblTemp(1, Compteur) = TblColonnesTri(1, Ligne)
Compteur = Compteur + 1
ReDim Preserve TblTemp(1, Compteur)
End If
End If
Next Ligne
TblColonnesTri = TblTemp
End Sub
Public Sub ModifieColonneTri(NumColCible As Byte, NvlleColonne As Byte, Optional SensTri As String = "ASC")
'Cette procédure modifie le numéro et / ou le sens du tri de la ligne NumColCible du tableau TblColonnesTri
Dim Taille As Byte, Ligne As Byte
Taille = UBound(TblColonnesTri, 2)
For Ligne = 0 To Taille
If TblColonnesTri(0, Ligne) = NumColCible Then
TblColonnesTri(0, Ligne) = NvlleColonne
TblColonnesTri(1, Ligne) = IIf(SensTri <> "DESC", "ASC", "DESC")
Exit For
End If
Next Ligne
End Sub
Private Sub Class_Initialize()
ReDim TblColonnesTri(1, 0)
PrecisionDecimal = 20
End Sub
Private Sub DetermineDimensions()
'Cette procédure regarde combien de dimensions a le tableau TableauATrier
On Error GoTo Erreurs
NbreDimensions = UBound(TableauATrier, 2)
'Si on arrive à ce stade, c'est qu'il n'y a pas eu d'erreur, donc que le tableau a deux diemnsions
NbreDimensions = 2
NbreLignes = UBound(TableauATrier, 2)
NbreColonnes = UBound(TableauATrier)
Exit Sub
Erreurs:
If Err.Number = 9 Then 'L'indice n'appartient pas à la sélection
'S'il y a eu une erreur, c'est que le tableau n'a qu'une seule dimension
NbreDimensions = 1
NbreLignes = UBound(TableauATrier)
Else
MsgBox Err.Description, vbCritical, "Erreur N° " & Err.Number
End If
End Sub
Private Function TriSurUneColonne(TblColonne As Variant, SensTri As String) As Variant
'Cette fonction retourne TblColonne trié par le sens SensTri
'SensTri peut être "ASC" ou "DESC"
Dim TblTemp As Variant, Ligne1 As Integer, Ligne2 As Integer, Ligne3 As Integer, Colonne As Byte, LigneRetenue As Integer
Dim NbreLignesVerifiees As Integer, Taille As Integer
'LigneRetenue permet de retenir de toutes les valeurs du tableau laquelle est la plus petite ou la plus grande
ReDim TblTemp(0)
Do
NbreLignesVerifiees = 0
For Ligne1 = 0 To NbreLignes
If IsNull(TblColonne(Ligne1)) Then
NbreLignesVerifiees = NbreLignesVerifiees + 1
If NbreLignesVerifiees = NbreLignes Then 'On remplit TblTemp avec la dernière valeur restante
For Ligne3 = 0 To NbreLignes
If Not IsNull(TblColonne(Ligne3)) Then TblTemp(NbreLignes) = TblColonne(Ligne3)
Next Ligne3
Exit Do
End If
Else
LigneRetenue = Ligne1
For Ligne2 = 0 To NbreLignes
If Ligne1 <> Ligne2 And Not IsNull(TblColonne(Ligne2)) Then
If SensTri = "ASC" Then
If TblColonne(Ligne2) <= TblColonne(LigneRetenue) Then LigneRetenue = Ligne2
Else
If TblColonne(Ligne2) >= TblColonne(LigneRetenue) Then LigneRetenue = Ligne2
End If
'On est obligé de faire <= ou >= au cas où il n'y ait dans le tableau que des valeurs identiques
'Si on ne mettait pas <= ou >=, on se retrouverait avec une boucle infinie dans le Do
End If
Next Ligne2
Exit For 'On a comparé la première valeur non nulle de la boucle Ligne1 avec toutes celles
'de la boucle Ligne2 => On sort de la boucle Ligne1 car on a la valeur la plus petite ou la plus grande
End If
Next Ligne1
'On affecte la valeur à TblTemp et on vide la cellule du tableau ayant été matchée
TblTemp(Taille) = TblColonne(LigneRetenue)
Taille = Taille + 1
ReDim Preserve TblTemp(Taille)
TblColonne(LigneRetenue) = Null
Loop
'On ne garde pas la dernière ligne s'il n'y a rien dedans
If IsEmpty(TblTemp(Taille)) Then ReDim Preserve TblTemp(Taille - 1)
TriSurUneColonne = TblTemp
End Function
Private Sub RemplitTblFinal(Val_a_InclureDsMotif As Variant, ColonneMotif As Byte)
'Cette procédure remplace le "*" initial du tableau TblFinal par la valeur contenue dans TableauATrier
'On construit le motif qui servira à indiquer où mettre la valeur Val_a_InclureDsMotif dans TblFinal
'Pour cela on concatène chaque valeur des colonnes de TblFinal de la Ligne de TblFinal
'sauf pour celle correspondant à ColonneTblFinal, qui elle, est remplacée par Val_a_InclureDsMotif
Dim Colonne As Byte, Ligne1 As Integer, Ligne2 As Integer, Motif As String, LigneConcatenee As String
Dim Drapeau As Boolean
For Ligne1 = 0 To NbreLignes 'TblFinal
'On construit le motif
Motif = ConcateneLigne(Ligne1, , ColonneMotif, Val_a_InclureDsMotif)
For Ligne2 = 0 To NbreLignes 'TableauATrier
'Maintenant qu'on a le motif, on construit une concaténation de Ligne2 qui est la ligne en cours TableauATrier
LigneConcatenee = ConcateneLigne(Ligne2, "TableauATrier")
'Au premier match, on remplit TblFinal avec Val_a_InclureDsMotif
'si et seulement si le contenu de la case de TblFinal est égal à "*"
If LigneConcatenee Like Motif And TblFinal(ColonneMotif, Ligne1) = "*" Then
TblFinal(ColonneMotif, Ligne1) = Val_a_InclureDsMotif
Drapeau = True
Exit For
End If
Next Ligne2
If Drapeau Then
Drapeau = False
Exit For
End If
Next Ligne1
End Sub
Public Function Nz(Valeur As Variant, Remplacement As String) As Variant
'Cette fonction est l'équivalent du Nz d'Access
Nz = IIf(Est_null(Valeur, , , False), Remplacement, Valeur)
End Function
Public Function Est_null(Objet As Variant, Optional Libelle As String = "", Optional Genre As Boolean = False, _
Optional Verbose As Boolean = False) As Boolean
' Cette fonction vérifie qu'une valeur n'est pas nulle
' Genre permet d'indiquer si on doit afficher en cas d'erreur "une" (True)
' ou "un" (False) dans la fenêtre "Veuillez en choisir ou en saisir un"
' Verbose sert à afficher ou non un message d'avertissement
'
'
' Paramètres : Objet : Variant
' Libelle : String (optionnel)
' Genre : String (optionnel défaut = False)
' Val : String (optionnel)
' Verbose : Boolean (optionnel défaut = False)
'
' Valeur de retour : Boolean
Dim Valeur As String
If IsObject(Objet) Then
Valeur = IIf(IsNull(Objet.Value), "", Objet.Value)
ElseIf Not IsNull(Objet) Then
Valeur = Objet
Else
Valeur = vbNullString
End If
If Len(Trim(Valeur)) = 0 Then
If Verbose Then
MsgBox Libelle & " est obligatoire." & vbCrLf & "Veuillez en choisir" & _
" ou en saisir un" & IIf(Genre = True, "e", "") & " s'il vous plaît", _
vbCritical, Libelle & " manque."
If IsObject(Objet) Then
Select Case TypeName(Objet)
Case "TextBox"
Objet.SetFocus
Case "Range"
Objet.Select
End Select
End If
End If
Est_null = True
End If
End Function
Private Function ConcateneLigne(LigneCible As Integer, Optional QuelTableau As String = "TblFinal", Optional ColonneCible As Byte, _
Optional ValRemplacement As Variant) As String
'Cette fonction concatène les valeurs contenues dans les colonnes de la ligne LigneCible du tableau QuelTableau
'et renvoie cette concaténation
'Si ValRemplacement est renseignée, elle remplace la valeur de la case de la colonne ColonneCible par celle-ci
Dim Colonne As Byte, Tableau As Variant
Tableau = IIf(QuelTableau = "TblFinal", TblFinal, TableauATrier)
If IsMissing(ValRemplacement) Then ValRemplacement = vbNullString 'Lorsque cette variable n'est pas renseignée
For Colonne = 0 To NbreColonnes
ConcateneLigne = ConcateneLigne & IIf(Len(ValRemplacement) > 0 And Colonne = ColonneCible, FormatePourMotif(ValRemplacement), _
FormatePourMotif(Nz(Tableau(Colonne, LigneCible), vbNullString)))
Next Colonne
End Function
Private Sub CombleTblFinal(Ligne_a_Combler As Integer)
'Cette procédure comble tous les "*" restant dans la ligne Ligne_a_Combler du tableau TblFinal
Dim Ligne As Integer, Motif As String, Colonne As Byte
Dim LigneConcatenee As String
'- On construit le motif de Ligne_a_Combler
'- On parcourt TableauATrier et pour chaque ligne on construit la concaténation
'- Si on match alors :
' - On remplace chaque colonne contenant un "*" par la valeur correspondante
' - On "désactive la ligne de TableauATrier en rendant nul le contenu de ses cellules
Motif = ConcateneLigne(Ligne_a_Combler)
For Ligne = 0 To NbreLignes
LigneConcatenee = ConcateneLigne(Ligne, "TableauATrier")
If LigneConcatenee Like Motif And Not IsNull(TableauATrier(0, Ligne)) Then
For Colonne = 0 To NbreColonnes
TblFinal(Colonne, Ligne_a_Combler) = TableauATrier(Colonne, Ligne)
TableauATrier(Colonne, Ligne) = Null
Next Colonne
'La procédure a remplit son bon office => On la quitte
Exit Sub
End If
Next Ligne
End Sub
Public Function Format_Longueur(Chaine As String, Caract As String, Optional Longueur As Integer = 0, Optional Sens = "G") As String
Dim Tampon As String
'Cette fonction permet d'ajouter avant ou après Chaine, en fonction de Sens, le caractère Caract afin que la chaine retournée fasse Longueur de long
If Longueur = 0 Or Len(Chaine) > Longueur Then
Format_Longueur = Chaine
Exit Function
End If
Tampon = String(Longueur - Len(Chaine), Caract)
Format_Longueur = IIf(Sens = "G", Tampon & Chaine, Chaine & Tampon)
End Function
Private Function FormatePourMotif(ByVal Valeur As Variant) As String
'Comme le motif est constitué de *, ce qui signifie n'importe quel nombre de caractères,
'On se retrouve, pour les nombres, avec des tris inexacts.
'Exemple : on doit trier 30 et 3 par ordre croissant sur deux colonnes.
'- Le motif élaboré est 3* car c'est 3 la valeur la plus petite
'Mais, dans la comparaison du motif avec les lignes, la première testée est 30
'- On se retrouve donc avec un match positif, car 30 matche avec "3*" ce qui n'est pas le résultat attendu
'Pour remédier à celà :
'On force un formatage des nombres sur PrecisionDecimal.
'Pour les dates, afin d'être certain de ne pas avoir de soucis de format de date français, anglo-saxons ou autres,
'on les caste en Double et on les formate sur PrecisionDecimal
'Pour les Booléen, on les caste en Entier
Dim Regle As New RegExp
If TypeName(Valeur) = "Boolean" Then
FormatePourMotif = IIf(Valeur, -1, 0)
ElseIf IsNumeric(Valeur) Or IsDate(Valeur) Then
Valeur = CDbl(Valeur)
Valeur = Replace(CStr(Valeur), ",", ".")
'Replace(CStr(Valeur), ",", ".") pour que le séparateur de décimales soit formaté à l'anglo-saxonne
With Regle
.Pattern = "^\d+$"
Valeur = Valeur & IIf(.Test(Valeur), ".", vbNullString)
'Valeur = Valeur & IIf(.Test(Valeur), ".", vbNullString)
'Le motif de l'expression rationnelle regarde s'il n'y a que des chiffres dans Valeur
'- Si c'est le cas, on ajoute un séparateur décimal, sinon, il y en a déjà et on a pas besoin de l'ajouter.
End With
FormatePourMotif = Mid(Valeur, 1, InStr(1, Valeur, ".")) & _
Format_Longueur(Mid(Valeur, InStr(1, Valeur, ".") + 1), "0", PrecisionDecimal, "D")
'On récupère les décimales en formatant sur PrecisionDecimal
Else
FormatePourMotif = Valeur
End If
End Function
Public Sub ReinitTblColonnesTri()
'Cette procédure supprime tous les critère de choix de colonne et de sens de tri
ReDim TblColonnesTri(1, 0)
End Sub
Conclusion :
Public Sub TriTableau()
Dim Tableau As Variant
Dim MonTrieur As New TrieurTableau, Ligne As Variant
Dim Ligne1 As Byte, Ligne2 As Byte
'Une dimension
ReDim Tableau(3)
Tableau(0) = 3: Tableau(1) = 1: Tableau(2) = 2: Tableau(3) = 0
With MonTrieur
.AttribueTableau = Tableau
.AjouteColonneTri 0, "DESC"
Tableau = .TableauTrie
End With
For Each Ligne In Tableau
Debug.Print Ligne
Next Ligne
'Deux dimensions
ReDim Tableau(3, 7)
Tableau(0, 0) = 10: Tableau(1, 0) = "A": Tableau(2, 0) = #3/25/1970#: Tableau(3, 0) = True
Tableau(0, 1) = 30: Tableau(1, 1) = "C": Tableau(2, 1) = #3/26/1970#: Tableau(3, 1) = True
Tableau(0, 2) = 20: Tableau(1, 2) = "B": Tableau(2, 2) = #3/27/1970#: Tableau(3, 2) = True
Tableau(0, 3) = 40: Tableau(1, 3) = "D": Tableau(2, 3) = #3/28/1970#: Tableau(3, 3) = True
Tableau(0, 4) = 1: Tableau(1, 4) = "A": Tableau(2, 4) = #3/29/1970#: Tableau(3, 4) = False
Tableau(0, 5) = 3: Tableau(1, 5) = "C": Tableau(2, 5) = #3/30/1970#: Tableau(3, 5) = False
Tableau(0, 6) = 2: Tableau(1, 6) = "B": Tableau(2, 6) = #3/31/1970#: Tableau(3, 6) = False
Tableau(0, 7) = 4: Tableau(1, 7) = "D": Tableau(2, 7) = #4/1/1970#: Tableau(3, 7) = False
With MonTrieur
.AttribueTableau = Tableau
'On supprime la colonne de tri qui a servi pour le test de tri
'du tableau à une dimension
'Si on ne fait pas cela, le premier tri se fera sur cette colonne, chose que l'on ne veut pas
'On pourrait aussi modifier celle-ci en saisissant
'.ModifieColonneTri 0, 1, "DESC"
.SupprimeColonneTri 0
.AjouteColonneTri 1, "DESC"
.AjouteColonneTri 3, "DESC"
.AjouteColonneTri 4
.ModifieColonneTri 3, 0, "ASC"
.SupprimeColonneTri 4
Tableau = .TableauTrie
End With
'On doit se retrouver avec le tableau trié comme suit
'4 D #4/1/1970# False
'40 D #3/28/1970# True
'3 C #3/30/1970# False
'30 C #3/26/1970# True
'2 B #3/31/1970# False
'20 B #3/27/1970# True
'1 A #3/29/1970# False
'10 A #3/25/1970# True
For Ligne1 = 0 To 7
For Ligne2 = 0 To 3
Debug.Print Tableau(Ligne2, Ligne1)
Next Ligne2
Next Ligne1
'Suite au bug sur le tri des valeurs numériques
'On fait des tests plus poussés
Tableau(0, 0) = 5: Tableau(1, 0) = "A": Tableau(2, 0) = #3/25/1970#: Tableau(3, 0) = True
Tableau(0, 1) = 3.14159: Tableau(1, 1) = "C": Tableau(2, 1) = #3/26/1970#: Tableau(3, 1) = True
Tableau(0, 2) = 3: Tableau(1, 2) = "B": Tableau(2, 2) = #3/1/1970#: Tableau(3, 2) = True
Tableau(0, 3) = 40: Tableau(1, 3) = "D": Tableau(2, 3) = #1/3/1970#: Tableau(3, 3) = True
Tableau(0, 4) = 1: Tableau(1, 4) = "A": Tableau(2, 4) = #3/30/1970 11:59:00 PM#: Tableau(3, 4) = False
Tableau(0, 5) = 3.000001: Tableau(1, 5) = "C": Tableau(2, 5) = #3/30/1970 12:01:00 AM#: Tableau(3, 5) = False
Tableau(0, 6) = 3.1416: Tableau(1, 6) = "B": Tableau(2, 6) = #3/31/1970 8:00:00 AM#: Tableau(3, 6) = False
Tableau(0, 7) = 4: Tableau(1, 7) = "D": Tableau(2, 7) = #3/31/1970 8:00:00 PM#: Tableau(3, 7) = True
With MonTrieur
.ReinitTblColonnesTri 'On supprime tous les précédents critères de tri
.AttribueTableau = Tableau
.NbreDecimales = 40 'On veut une précision des décimales pour les nombres de 40 au lieu des 20 définis par défaut
'Tri sur les nombres
.AjouteColonneTri 0
Tableau = .TableauTrie
End With
'Tri sur les nombres :
'On doit se retrouver avec le tableau trié comme suit
'1 A #3/30/1970 11:59:00 PM# False
'3 B #3/1/1970# True
'3.000001 C #3/30/1970 12:01:00 AM# False
'3.14159 C #3/26/1970# True
'3.1416 B #3/31/1970 8:00:00 AM# False
'4 D #3/31/1970 8:00:00 PM# True
'5 A #3/25/1970# True
'40 D #1/3/1970# True
For Ligne1 = 0 To 7
For Ligne2 = 0 To 3
Debug.Print Tableau(Ligne2, Ligne1)
Next Ligne2
Next Ligne1
'Tri sur les dates
With MonTrieur
.AttribueTableau = Tableau
.ModifieColonneTri 0, 2
Tableau = .TableauTrie
End With
For Ligne1 = 0 To 7
For Ligne2 = 0 To 3
Debug.Print Tableau(Ligne2, Ligne1)
Next Ligne2
Next Ligne1
'Tri sur les dates
'On doit se retrouver avec le tableau trié comme suit
'40 D #1/3/1970# True
'3 B #3/1/1970# True
'5 A #3/25/1970# True
'3.14159 C #3/26/1970# True
'3.000001 C #3/30/1970 12:01:00 AM# False
'1 A #3/30/1970 11:59:00 PM# False
'3.1416 B #3/31/1970 8:00:00 AM# False
'4 D #3/31/1970 8:00:00 PM# True
End Sub
Vous n'êtes pas encore membre ?
inscrivez-vous, c'est gratuit et ça prend moins d'une minute !
Les membres obtiennent plus de réponses que les utilisateurs anonymes.
Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.
Le fait d'être membre vous permet d'avoir des options supplémentaires.