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
| Option Explicit
Sub TrierLesOnglets()
Dim Sh As Worksheet
Dim ShTri As Worksheet
Dim ShEnCours As Worksheet
Dim Cellule As Range
Dim LigneTitreTri As Long
Dim LigneEnCoursTri As Long
Dim DerniereLigneTri As Long
Dim CtrI As Long
Dim CreationFeuilleTri As Boolean
Dim DesTructionFeuillesCachees As Boolean
Dim MatriceFeuilles() As Variant
Dim NomFeuille As String
Dim NomFeuilleTri As String
Dim NomFeuilleModifie As String
CreationFeuilleTri = True
DesTructionFeuillesCachees = True
For Each Sh In Worksheets
If Sh.Name = "Liste des onglets" Then CreationFeuilleTri = False
Next Sh
If CreationFeuilleTri = True Then
Sheets.Add after:=Sheets(Sheets.Count)
ActiveSheet.Name = "Liste des onglets"
End If
Set ShTri = Sheets("Liste des onglets")
NomFeuilleTri = "'" & "Liste des onglets" & "'" ' Pour les liens hypertextes
LigneTitreTri = 1
ShTri.Cells(LigneTitreTri, 1) = "Onglets"
LigneEnCoursTri = LigneTitreTri + 1
ShTri.Range(ShTri.Cells(LigneTitreTri + 1, 1), ShTri.Cells(ShTri.Rows.Count, 1)).Clear
ShTri.Activate
' Renommage des feuilles de NOTES 00 à NOTES 09
For Each Sh In Worksheets
If Sh.Name <> ShTri.Name Then
Sh.Activate
NomFeuilleModifie = Sh.Name
Select Case Mid(Sh.Name, 1, 5)
Case "NOTE "
Select Case Mid(Sh.Name, Len("NOTE XX"), 1)
Case ".", " "
ActiveSheet.Name = "NOTE " & Mid(NomFeuilleModifie, Len("NOTE X"))
End Select
If Len(Sh.Name) = Len("NOTE X") Then ActiveSheet.Name = "NOTE " & Mid(NomFeuilleModifie, Len("NOTE X"))
End Select
End If
Next Sh
' Destruction des feuilles cachées
If DesTructionFeuillesCachees = True Then
For CtrI = Worksheets.Count To 1 Step -1
Select Case Worksheets(CtrI).Visible
Case False
Application.DisplayAlerts = False
Worksheets(CtrI).Delete
Application.DisplayAlerts = False
End Select
Next CtrI
End If
' Etablissement de la liste des feuilles dans Liste des onglets
For Each Sh In Worksheets
If Sh.Name <> ShTri.Name Then
ShTri.Cells(LigneEnCoursTri, 1) = Sh.Name
LigneEnCoursTri = LigneEnCoursTri + 1
End If
Next Sh
ShTri.Activate
' Tri de la liste des onglets
With ShTri
.Columns("A:A").Select
Selection.Sort Key1:=.Cells(LigneTitreTri, 1), Order1:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
End With
' Chargement de la matrice des onglets
DerniereLigneTri = ShTri.Cells(ShTri.Rows.Count, 1).End(xlUp).Row
ShTri.Range(ShTri.Cells(LigneTitreTri + 1, 1), ShTri.Cells(DerniereLigneTri, 1)).Select
ReDim MatriceFeuilles(Selection.Count - 1)
CtrI = 0
For Each Cellule In Selection
MatriceFeuilles(CtrI) = Cellule
CtrI = CtrI + 1
Next Cellule
' Déplacement des feuilles
For CtrI = UBound(MatriceFeuilles, 1) To LBound(MatriceFeuilles, 1) Step -1
Select Case Mid(MatriceFeuilles(CtrI), 1, 5)
Case "NOTE "
Sheets(MatriceFeuilles(CtrI)).Move before:=Sheets(1)
End Select
Next CtrI
' Déplacement de la feuille Liste des onglets en position 1
ShTri.Move before:=Sheets(1)
ShTri.Range(ShTri.Cells(LigneTitreTri + 1, 1), ShTri.Cells(ShTri.Rows.Count, 2)).Clear
' Raffraichissement de la feuille Liste des onglets
LigneEnCoursTri = LigneTitreTri + 1
For Each Sh In Worksheets
If Sh.Name <> ShTri.Name Then
Set ShEnCours = Sheets(Sh.Name)
ShTri.Cells(LigneEnCoursTri, 1) = Sh.Name
If Sh.Visible = xlSheetHidden Then
ShTri.Cells(LigneEnCoursTri, 2) = "Cachée"
Else
ShTri.Cells(LigneEnCoursTri, 2) = "Lien"
NomFeuille = "'" & Sh.Name & "'" ' Pour les liens hypertextes
' Crée un lien hypertexte à partir du nom de l'onglet avec l'onglet lui-même
ShTri.Hyperlinks.Add Anchor:=ShTri.Cells(LigneEnCoursTri, 2), Address:="", SubAddress:=NomFeuille & "!A1", TextToDisplay:="Lien"
' Crée un lien hypertexte entre la nouvelle feuille client et le client de la feuille des clients
ShEnCours.Hyperlinks.Add Anchor:=ShEnCours.Range("A1"), Address:="", SubAddress:=NomFeuilleTri & "!B" & LigneEnCoursTri, TextToDisplay:="Retour liste des onglets"
End If
LigneEnCoursTri = LigneEnCoursTri + 1
Set ShEnCours = Nothing
End If
Next Sh
' Mise en forme
ShTri.Activate
With ShTri
.Columns("A:A").EntireColumn.AutoFit
With .Range("A1")
.Font.Bold = True
.Interior.Pattern = xlSolid
.Interior.PatternColorIndex = xlAutomatic
.Interior.Color = 65535
End With
.Range("A2").Select
ActiveWindow.FreezePanes = True
.Range("A1").Select
End With
Set ShTri = Nothing
End Sub |
Trier onglet classeur excel par ordre croissant numéro et alphabétique
Répondre avec citation
Envoyé par Anna_2013
Partager