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 239 240 241 242 243 244 245
| Private Sub Workbook_Open()
Dim ws As Worksheet
Dim tbl As ListObject
' Désactiver les événements et le rafraîchissement d'écran
Application.EnableEvents = False
Application.ScreenUpdating = False
' Déprotéger la feuille, désactiver les icônes de filtrage, puis reprotéger la feuille
For Each ws In ThisWorkbook.Worksheets
ws.Unprotect Password:=""
For Each tbl In ws.ListObjects
tbl.ShowAutoFilter = False
Next tbl
ws.Protect Password:="", UserInterfaceOnly:=True
Next ws
' Réactiver les événements et le rafraîchissement d'écran
'Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim tbl As ListObject
Dim triableCols As Collection
Dim filterableCols As Collection
Dim col As Variant
On Error GoTo EnableEvents
Set triableCols = New Collection
Set filterableCols = New Collection
triableCols.Add 2 ' Colonne 2 dans le tableau structuré (B)
triableCols.Add 11 ' Colonne 11 dans le tableau structuré (K)
filterableCols.Add 2 ' Colonne 2 dans le tableau structuré (D)
filterableCols.Add 3 ' Colonne 3 dans le tableau structuré (E)
filterableCols.Add 4 ' Colonne 4 dans le tableau structuré (F)
filterableCols.Add 5 ' Colonne 5 dans le tableau structuré (G)
' Définir le tableau structuré
Set tbl = ActiveSheet.ListObjects("Rapports_médicaux")
' MsgBox "Début de Worksheet_BeforeDoubleClick"
' Désactiver les événements pour éviter les déclenchements récursifs
Application.EnableEvents = False
' MsgBox "Avant de vérifier la cellule"
' Vérifier si le double-clic est sur une cellule pour filtrer
If Not Intersect(Target, tbl.DataBodyRange) Is Nothing Then
' MsgBox "Double-clic sur une cellule dans la plage de données"
For Each col In filterableCols
' MsgBox "Vérification de la colonne " & col & " contre la colonne cible " & (Target.Column - tbl.Range.Column + 1)
If (Target.Column - tbl.Range.Column + 1) = col Then
' MsgBox "La cellule est dans les colonnes filtrables"
' Vérifier si la colonne est déjà filtrée
If Not tbl.AutoFilter Is Nothing Then
If tbl.AutoFilter.Filters.Count >= col And tbl.AutoFilter.Filters(col).On Then
' MsgBox "Réinitialisation du filtrage pour la colonne"
RéinitialiserFiltrageColonne CInt(col)
Else
' MsgBox "Application du filtrage exact"
' Appliquer le filtre exact
FiltreExact CInt(col), Target.Value, True
End If
Else
' MsgBox "Application du filtrage exact"
' Appliquer le filtre exact
FiltreExact CInt(col), Target.Value, True
End If
Cancel = True
GoTo EnableEvents
End If
Next col
' MsgBox "Colonne non trouvée dans les colonnes filtrables"
GoTo EnableEvents
End If
' MsgBox "Avant de vérifier l'en-tête"
' Vérifier si le double-clic est sur l'en-tête pour trier ou réinitialiser
If Not Intersect(Target, tbl.HeaderRowRange) Is Nothing Then
For Each col In triableCols
' MsgBox "Vérification de la colonne triable " & col & " contre la colonne cible " & (Target.Column - tbl.Range.Column + 1)
If (Target.Column - tbl.Range.Column + 1) = col Then
' MsgBox "L'en-tête est dans les colonnes triables"
TriColonne CInt(col)
Cancel = True
GoTo EnableEvents
End If
Next col
For Each col In filterableCols
' MsgBox "Vérification de la colonne filtrable " & col & " contre la colonne cible " & (Target.Column - tbl.Range.Column + 1)
If (Target.Column - tbl.Range.Column + 1) = col Then
' MsgBox "L'en-tête est dans les colonnes filtrables"
RéinitialiserFiltrage
Cancel = True
GoTo EnableEvents
End If
Next col
' MsgBox "Aucune colonne correspondante trouvée dans les en-têtes"
GoTo EnableEvents
End If
' MsgBox "Après vérification de l'en-tête"
EnableEvents:
' Réactiver les événements
Application.EnableEvents = True
End Sub
Sub RéinitialiserFiltrage()
Dim tbl As ListObject
Dim cell As Range
' Définir le tableau structuré
Set tbl = ActiveSheet.ListObjects("Rapports_médicaux")
' MsgBox "Début de la réinitialisation du filtrage"
' Afficher toutes les lignes du tableau
Application.ScreenUpdating = False
For Each cell In tbl.ListColumns(1).DataBodyRange
cell.EntireRow.Hidden = False
Next cell
Application.ScreenUpdating = True
' MsgBox "Filtrage réinitialisé"
End Sub
Sub RéinitialiserFiltrageColonne(colIndex As Integer)
Dim tbl As ListObject
Dim cell As Range
Dim otherFilters As Collection
Dim col As Variant
' Définir le tableau structuré
Set tbl = ActiveSheet.ListObjects("Rapports_médicaux")
Set otherFilters = New Collection
' MsgBox "Début de la réinitialisation du filtrage pour la colonne " & colIndex
' Trouver les autres colonnes qui sont filtrées
For col = 1 To tbl.ListColumns.Count
If col <> colIndex Then
If tbl.AutoFilter.Filters(col).On Then
otherFilters.Add col
End If
End If
Next col
' Afficher toutes les lignes du tableau pour la colonne spécifiée
Application.ScreenUpdating = False
tbl.Range.AutoFilter Field:=colIndex
For Each cell In tbl.ListColumns(colIndex).DataBodyRange
cell.EntireRow.Hidden = False
Next cell
' Réappliquer les filtres des autres colonnes
For Each col In otherFilters
tbl.Range.AutoFilter Field:=col, Criteria1:=tbl.AutoFilter.Filters(col).Criteria1
Next col
Application.ScreenUpdating = True
' MsgBox "Filtrage de la colonne réinitialisé"
End Sub
Sub FiltreExact(colIndex As Integer, filtreValeur As String, Optional filtreVisibleSeulement As Boolean = False)
Dim tbl As ListObject
Dim cell As Range
Dim found As Boolean
Dim cellValue As String
' Définir le tableau structuré
Set tbl = ActiveSheet.ListObjects("Rapports_médicaux")
' MsgBox "Début du filtrage exact sur la colonne " & colIndex
' Appliquer le filtrage exact
Application.ScreenUpdating = False
found = False
For Each cell In tbl.ListColumns(colIndex).DataBodyRange
If Not filtreVisibleSeulement Or cell.EntireRow.Hidden = False Then
cellValue = cell.Value
' MsgBox "Comparaison de la valeur de la cellule: " & cellValue & " avec la valeur du filtre: " & filtreValeur
If cellValue = filtreValeur Then
cell.EntireRow.Hidden = False
found = True
Else
cell.EntireRow.Hidden = True
End If
End If
Next cell
Application.ScreenUpdating = True
If found Then
' MsgBox "Filtrage appliqué"
Else
' MsgBox "Aucune correspondance trouvée"
End If
End Sub
Sub TriColonne(colIndex As Integer)
Dim tbl As ListObject
Dim currentOrder As XlSortOrder
' Définir le tableau structuré
Set tbl = ActiveSheet.ListObjects("Rapports_finaux")
' MsgBox "Début du tri sur la colonne " & colIndex
' Déterminer l'ordre de tri actuel
If tbl.Sort.SortFields.Count > 0 Then
If tbl.Sort.SortFields(1).Order = xlAscending Then
currentOrder = xlDescending
Else
currentOrder = xlAscending
End If
Else
currentOrder = xlAscending
End If
' Effectuer le tri sur la colonne spécifiée
tbl.Sort.SortFields.Clear
tbl.Sort.SortFields.Add Key:=tbl.ListColumns(colIndex).Range, _
SortOn:=xlSortOnValues, Order:=currentOrder, DataOption:=xlSortNormal
With tbl.Sort
.Header = xlOui
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
' MsgBox "Tri effectué"
End Sub |
Partager