1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62
| Option Explicit
Public Sub SortTable(Table As Range, Optional lstCol As String, Optional sHeader As Byte = xlGuess, Optional Extend As Boolean = True)
' Procédure de Tri - fonctionne avec les versions 2003-2010
' Author : Philippe Tulliez
' Date : 12-03-27
' Version : 1.3
' Arguments
' Table - Range fait référence à la feuille et à la plage à trier
' [lstCol] - String Liste des colonnes à trier séparé par un point virgule. Si n° négatif, tri descendant
' par défaut première colonne de la table. Exemple lstCol:="2;4;-6"
' [sHeader]- Défini si la table à une en-tête. (xlGuess 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
Const ErrTitle As String = "Procédure - SortTable":
Dim ErrMsg As String: ErrMsg = "*** Sortie de procédure ***" & vbCrLf & vbCrLf
' dim ErrArgList = "Arguments " & vbCrLf & vbTab & "Table = " & Table.Address
Dim tCol() As String, c As Long
Dim pSort(1 To 3) As Byte, rCol(1 To 3) As String
Application.ScreenUpdating = False
Dim sht As Worksheet: Set sht = ActiveSheet: Table.Parent.Activate
c = Table.Column
Select Case Table.Count ' Table = une cellule
Case 1
If Extend Then
Set Table = Table.CurrentRegion: If Len(lstCol) = 0 Then lstCol = c - Table.Column + 1
Else
With sht: Set Table = .Range(.Cells(Table.Row, Table.Column), .Cells(Table.End(xlDown).Row, Table.Column)): End With
End If
Case Else
If Extend Then Set Table = Table.CurrentRegion
End Select
If Table.Cells.Count = 1 Then
MsgBox ErrMsg & "Problème plage " & vbCrLf & Table.Parent.Name & " " & Table.Address, vbCritical, ErrTitle: Exit Sub
End If
If Len(lstCol) = 0 Then lstCol = Cells.Column ' Si lstCol vide -> lstCol = première colonne du tableau
tCol = Split(lstCol, ";")
For c = 0 To UBound(tCol) - (Abs((UBound(tCol) > 3) * (UBound(tCol) - 3))) ' Maximum 3 niveaux de tri
With Table
If Val(tCol(c)) = 0 Then tCol(c) = 1 ' Si Colonne 0 alors Colonne 1
If Abs(tCol(c)) + .Column - 1 < .Column Or Abs(tCol(c)) + .Column - 1 >= .Column + .Columns.Count Then
' Message d'erreur si colonne à trier > nbre colonnes de la table et sortie du tri
MsgBox ErrMsg & "Impossible de trier la colonne " & Abs(tCol(c)) _
& vbCrLf & "La plage " & Table.Address & " de la feuille " & Table.Parent.Name _
& vbCrLf & "ne contient que " & .Columns.Count & " colonnes", vbCritical, ErrTitle
Exit Sub ' Sortie du tri
End If
If Val(tCol(c)) < 0 Then pSort(c + 1) = xlDescending Else pSort(c + 1) = xlAscending
rCol(c + 1) = Cells(.Row + 1, .Column + Abs(tCol(c)) - 1).Address
End With
Next c
If UBound(tCol) < 2 Then
For c = UBound(tCol) + 1 To 2: rCol(c + 1) = rCol(c): pSort(c + 1) = pSort(c): Next
End If
With Table ' 2 - Tri
.Sort _
Key1:=Range(rCol(1)), Order1:=pSort(1), _
Key2:=Range(rCol(2)), Order2:=pSort(2), _
Key3:=Range(rCol(3)), Order2:=pSort(3), _
Header:=sHeader, OrderCustom:=1, MatchCase:=False
End With
sht.Activate ' Focus sur Feuille Active avt Procédure
Application.ScreenUpdating = True
End Sub |
Partager