Je vous propose une procédure de tri basée sur l’ancienne méthode Sort de l’objet Range afin de garder une portabilité avec la version 2003. Elle est donc limitée à 3 niveaux de tri.
Cette procédure nommée SortTable (version 5,1) à six arguments dont un seul est obligatoire.
Les arguments
Ils sont au nombre de six et un seul est obligatoire.
SheetOrRange de type (Object) pouvant être une feuille ou un Range.
Si l’objet est de type worksheet, on considère que la table commence à la cellule A1 de cette feuille
[SortList] – (String) liste des n° de colonnes à trier séparés par un point virgule
Le n° de colonne correspond au n° de colonne dans la table
Si le n° est négatif le tri est descendant. Exemple SortList:= »2;4;-6″
Si le n° contient une décimale et que la ligne ou la colonne à trier contient du texte convertible en nombres (exemple 13.2 4.2 ou ‘100 / ‘70050), le tri se fera comme un numérique (option xlSortTextAsNumbers de l’argument DataOptionX de la méthode Sort)
[Header] – (Boolean) Défini si la table à une en-tête. (xlYes pas défaut).
[Extend] – (Boolean). Indique si la référence à la table doit être étendue (Cas de colonne unique contigüe). True par défaut
[Orientation] – (Byte) Tri par colonne [default] (xlSortColumns/xlTopToBottom/1) ou par ligne (xlSortRows/xlLeftToRight/2)
[CustomList] – (String). Permet de faire un tri personnalisé sur la première clé. La liste doit être séparée par des points virgules. Exemple : « La plus grande distinction;Grande distinction;Distinction;Satisfaction »
Le code
Public Sub SortTable(SheetOrRange As Object, Optional SortList As String = "1", _
Optional Header As Boolean = True, Optional Extend As Boolean = True, _
Optional Orientation As Byte = xlSortColumns, Optional CustomList As String)
' Procédure de Tri - fonctionne avec les versions 2003-2010
' Author : Philippe Tulliez
' Date : 2013-06-21 (Version 1 du 2012-04-01)
' Version : 5.1
' Arguments
' SheetOrRange - Objet pouvant être une feuille ou un Range.
' Si l'objet est Worksheet, on considère que la table commence à la cellule "A1" de cette feuille
' [SortList] - String Liste des n° de colonnes à trier séparé par un point virgule
' Le n° de colonne correspond au n° de colonne dans la table
' Si le n° est négatif le tri est descendant. Exemple SortList:="2;4;-6"
' Si le n° contient une décimale et que la ligne ou la colonne à trier
' contient du texte convertible en nombres (exemple 13.2 4.2 ou '100 / '70050)
' le tri se fera comme un numérique (option de l'argument DataOptionX de la méthode Sort)
' [Header] - Défini si la table à une en-tête. (xlYes pas défaut).
' [Extend] - Boolean. Indique si la référence à la table doit être étendue (Cas de colonne unique contigüe). True par défaut
' [Orientation] - Tri par colonne [default] (xlSortColumns/xlTopToBottom/1) ou par ligne (xlSortRows/xlLeftToRight/2)
' [CustomList] - de type String, permet de faire un tri personnalisé sur la première clé
' La liste doit être séparée par des points virgules. Exemple : "Très bon;Bon;Moyen;Pas bon"
Const ErrTitle As String = "Procédure - SortTable"
Dim ErrMsg As String: ErrMsg = "*** Sortie de procédure ***" & vbCrLf & vbCrLf
Dim Table As Range, tblSortList() As String, sTbl_1 As String, c As Long
Dim SortOrder(1 To 3) As Byte, SortAddr(1 To 3) As String, SortTxtVal(1 To 3) As Byte
Dim Row As Long, Col As Integer
On Error GoTo ErrorHandle
Select Case True ' Test 1er argument
Case TypeOf SheetOrRange Is Worksheet: Set Table = SheetOrRange.Range("A1")
Case TypeOf SheetOrRange Is Range: Set Table = SheetOrRange
Case Else: Error 10001 ' Goto Gestionnaire d'erreur
End Select
Select Case Extend
Case True: Set Table = Table.CurrentRegion
Case False
With Table.Worksheet: Set Table = .Range(.Cells(Table.Row, Table.Column), .Cells(Table.End(xlDown).Row, Table.Column)): End With
End Select
If Orientation = xlSortRows And Header = True Then
With Table: Set Table = .Offset(, 1).Resize(, .Columns.Count - 1): End With
End If
If Table.Cells.Count = 1 Then Error 10002 ' Goto Gestionnaire d'erreur
tblSortList = Split(SortList, ";")
' Affectation des valeurs à SortOrder, SortAddr, SortTxtVal
For c = 0 To 2
If (c > UBound(tblSortList)) Then sTbl_1 = Val(tblSortList(UBound(tblSortList))) Else sTbl_1 = Val(tblSortList(c))
SortTxtVal(c + 1) = xlSortNormal + Abs((sTbl_1 <> Int(sTbl_1))): sTbl_1 = Int(sTbl_1) ' xlSortNormal/xlSortTextAsNumbers
With Table
' Ctrl si n°ligne/colonne à trier pas > Ligne/Colonne de Table + Calcul SortAddr & SortOrder
Select Case Orientation
Case xlSortColumns: If Abs(sTbl_1) + .Column - 1 >= .Column + .Columns.Count Then Error 10003
Row = .Row + Abs(Header = True): Col = .Column + Abs(sTbl_1) - 1
Case xlSortRows: If Abs(sTbl_1) + .Row - 1 >= .Row + .Rows.Count Then Error 10003
Row = .Row + Abs(sTbl_1) - 1: Col = .Column
End Select
SortOrder(c + 1) = xlAscending + Abs(Val(sTbl_1) < 0): SortAddr(c + 1) = Cells(Row, Col).Address
End With
Next c
' *** Sort ***
If Len(CustomList) Then Application.AddCustomList ListArray:=Split(CustomList, ";") ' Tri sur liste personnalisée
With Table
.Sort _
Key1:=.Worksheet.Range(SortAddr(1)), Order1:=SortOrder(1), DataOption1:=SortTxtVal(1), _
Key2:=.Worksheet.Range(SortAddr(2)), Order2:=SortOrder(2), DataOption2:=SortTxtVal(2), _
Key3:=.Worksheet.Range(SortAddr(3)), Order2:=SortOrder(3), DataOption3:=SortTxtVal(3), _
Header:=xlNo + Header, Orientation:=Orientation, MatchCase:=False, _
OrderCustom:=1 + (Application.CustomListCount * Abs(Len(CustomList) > 0))
End With
If Len(CustomList) Then With Application: .DeleteCustomList .CustomListCount: End With ' Destruction de la liste personnalisée
On Error GoTo 0: Set Table = Nothing: Exit Sub ' *** Fin de procédure ***
' Gestionnaire des erreurs de la procédure
ErrorHandle:
Select Case Err
Case 10001: Err.Description = "Variable Objet (SheetOrRange) mal définie (WorkSheet) ou (Range)"
Case 10002 ' Pas de plage à trier (Une seule Cellule)
With Table
Err.Description = "Argument : SheetOrRange, référence passée= " & .Worksheet.Name & "!" & .Address & vbCrLf & "Pas de plage à trier"
End With
Case 10003 ' Dépassement de capacité (ligne ou colonne à trier hors de la table
With Err
.Description = "Problème d'argument [SortList] = " & SortList
.Description = .Description & vbCrLf & "Impossible de trier la " & IIf(Orientation = xlSortColumns, "colonne ", "ligne ") & Abs(tblSortList(c))
.Description = .Description & vbCrLf & "La plage " & Table.Address & " de la feuille [" & Table.Worksheet.Name & "]"
.Description = .Description & ", ne contient que " & IIf(Orientation = xlSortColumns, Table.Columns.Count, Table.Rows.Count)
.Description = .Description & IIf(Orientation = xlSortColumns, " colonnes.", " lignes.")
End With
End Select
MsgBox ErrMsg & Err.Description, vbCritical, Title:=ErrTitle
On Error GoTo 0: Set Table = Nothing: Exit Sub
End Sub
Classeur exemple à télécharger
[wpdm_package id=’717′]
Commentaires récents