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 |
Partager