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 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238
| Private Sub Workbook_Open()
RéinitialiserTousLesFiltres
End Sub
Module standard
Sub RéinitialiserTousLesFiltres()
Dim ws As Worksheet
Dim tbl As ListObject
Dim headerCell As Range
Application.ScreenUpdating = False
Application.EnableEvents = False
For Each ws In ThisWorkbook.Worksheets
On Error Resume Next
Set tbl = ws.ListObjects("Rapports_finaux")
If Not tbl Is Nothing Then
tbl.Range.AutoFilter
For Each headerCell In tbl.HeaderRowRange
headerCell.Value = Trim(headerCell.Value)
Next headerCell
End If
On Error GoTo 0
Next ws
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Sub RéinitialiserFiltrageColonne(tbl As ListObject, colIndex As Integer)
Application.ScreenUpdating = False
' Réinitialiser uniquement le filtre de la colonne spécifiée
tbl.Range.AutoFilter Field:=colIndex
' Faire défiler la feuille de calcul vers le haut pour afficher les en-têtes
ActiveWindow.ScrollRow = 1
' Masquer les icônes de filtrage
On Error Resume Next
If tbl.ShowAutoFilter Then
ActiveSheet.Unprotect
tbl.ShowAutoFilter = False
ActiveSheet.Protect
End If
On Error GoTo 0
Application.ScreenUpdating = True
End Sub
Sub FiltreExact(tbl As ListObject, colIndex As Integer, filtreValeur As String)
Application.ScreenUpdating = False
' Debug message
MsgBox "Application du filtrage exact sur la colonne " & colIndex & " avec la valeur " & filtreValeur
' Appliquer le filtrage sur la colonne spécifiée
tbl.Range.AutoFilter Field:=colIndex, Criteria1:=filtreValeur
' Faire défiler la feuille de calcul vers le haut pour afficher les en-têtes
ActiveWindow.ScrollRow = 1
' Masquer les icônes de filtrage
On Error Resume Next
If tbl.ShowAutoFilter Then
ActiveSheet.Unprotect
tbl.ShowAutoFilter = False
ActiveSheet.Protect
End If
On Error GoTo 0
Application.ScreenUpdating = True
End Sub
Module de feuille de calcul
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim tbl As ListObject
Dim colIndex As Integer
' Désactiver les événements pour éviter les déclenchements récursifs
Application.EnableEvents = False
' Définir le tableau structuré
Set tbl = ActiveSheet.ListObjects("Rapports_finaux")
' Debug messages
MsgBox "Début de Worksheet_BeforeDoubleClick"
' Vérifier si le double-clic est sur une cellule pour filtrer
If Not Intersect(Target, tbl.DataBodyRange) Is Nothing Then
colIndex = Target.Column - tbl.Range.Column + 1
' Debug messages
MsgBox "Double-clic sur une cellule dans la colonne " & colIndex
' Vérifier l'état du filtrage
If GetFilterState(tbl, colIndex) = "Filtrage activé" Then
MsgBox "Filtrage déjà activé, réinitialisation..."
RéinitialiserFiltrageColonne tbl, colIndex
SetFilterState tbl, colIndex, "Filtrage désactivé"
Else
MsgBox "Aucun filtrage actif, application du filtrage..."
FiltreExact tbl, colIndex, Target.Value
SetFilterState tbl, colIndex, "Filtrage activé"
End If
' Masquer les icônes de filtrage
On Error Resume Next
ActiveSheet.Unprotect
tbl.ShowAutoFilter = False
ActiveSheet.Protect
On Error GoTo 0
Cancel = True
GoTo EnableEvents
End If
' Vérifier si le double-clic est sur l'en-tête pour trier ou réinitialiser
If Not Intersect(Target, tbl.HeaderRowRange.Cells(1, 2)) Is Nothing Then
MsgBox "Double-clic sur l'en-tête de la colonne Clients pour tri"
TriColonneD tbl
' Masquer les icônes de filtrage
On Error Resume Next
ActiveSheet.Unprotect
tbl.ShowAutoFilter = False
ActiveSheet.Protect
On Error GoTo 0
Cancel = True
GoTo EnableEvents
End If
EnableEvents:
' Réactiver les événements
Application.EnableEvents = True
MsgBox "Fin de Worksheet_BeforeDoubleClick"
End Sub
' Fonction pour obtenir l'état du filtrage
Function GetFilterState(tbl As ListObject, colIndex As Integer) As String
Dim headerCell As Range
Set headerCell = tbl.HeaderRowRange.Cells(1, colIndex)
If Right(headerCell.Value, 1) = " " Then
GetFilterState = "Filtrage activé"
Else
GetFilterState = "Filtrage désactivé"
End If
End Function
' Sub pour définir l'état du filtrage
Sub SetFilterState(tbl As ListObject, colIndex As Integer, state As String)
Dim headerCell As Range
Set headerCell = tbl.HeaderRowRange.Cells(1, colIndex)
Application.EnableEvents = False
If state = "Filtrage activé" Then
headerCell.Value = Trim(headerCell.Value) & " "
headerCell.Interior.Color = RGB(105, 105, 105) ' Gris foncé
Else
headerCell.Value = Trim(headerCell.Value)
headerCell.Interior.Color = RGB(172, 185, 202) ' Couleur d'origine
End If
Application.EnableEvents = True
End Sub
' Sub pour trier la colonne D et mettre à jour l'en-tête
Sub TriColonneD(tbl As ListObject)
Dim headerCell As Range
Dim currentOrder As XlSortOrder
Dim arrowColor As Long
arrowColor = RGB(255, 0, 0) ' Couleur de la flèche (rouge, pour l'exemple)
Set headerCell = tbl.HeaderRowRange.Cells(1, 2) ' Colonne D
' Debug messages
MsgBox "Début du tri de la colonne D"
' Déterminer l'ordre de tri actuel
If InStr(headerCell.Value, "▲") > 0 Then
currentOrder = xlDescending
headerCell.Value = "Clients ▼"
ElseIf InStr(headerCell.Value, "▼") > 0 Then
currentOrder = xlAscending
headerCell.Value = "Clients ▲"
Else
' Si aucun tri n'est défini, commencer par l'ordre ascendant
currentOrder = xlAscending
headerCell.Value = "Clients ▲"
End If
' Debug messages
MsgBox "Ordre de tri déterminé : " & IIf(currentOrder = xlAscending, "Ascendant", "Descendant")
' Effectuer le tri sur la colonne D
tbl.Sort.SortFields.Clear
tbl.Sort.SortFields.Add Key:=tbl.ListColumns(2).Range, _
SortOn:=xlSortOnValues, Order:=currentOrder, DataOption:=xlSortNormal
With tbl.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
' Debug messages
MsgBox "Tri appliqué"
' Ajouter un espace pour indiquer que le tri est activé
headerCell.Value = headerCell.Value & " "
headerCell.Interior.Color = RGB(105, 105, 105) ' Gris foncé
' Colorer la flèche
If InStr(headerCell.Value, "▲") > 0 Then
headerCell.Characters(Start:=Len("Patients") + 10, Length:=1).Font.Color = arrowColor
ElseIf InStr(headerCell.Value, "▼") > 0 Then
headerCell.Characters(Start:=Len("Patients") + 10, Length:=1).Font.Color = arrowColor
End If
' Debug messages
MsgBox "Flèche colorée"
' Faire défiler la feuille de calcul vers le haut pour afficher les en-têtes
ActiveWindow.ScrollRow = 1
' Debug messages
MsgBox "Fin du tri de la colonne D"
End Sub |
Partager