VBA Macro tri onglets

Anna_2013

XLDnaute Junior
Bonjour,

J'ai un problème pour modifier la syntaxe de la macro que j'ai créer pour trier plus de 35 onglets dans un fichier excel.

J'ai joint le code (Macro Trier les onglets) et les onglets à trier. Chaque onglet commence par NOTE puis un numéro lui est associé.

Pourriez vous svp m'aider à modifier la syntaxe. Je suis débutante sur VBA et j'ai essayé de la modifer mais cela ne fonctionne pas. D'autre part une page créant la liste des onglets devraient s'afficher mais cela ne fonctionne pas avc le nombre d'onglet.

Par avance merci pour votre aide,

Anna

Macro trier les onglets
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 27
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
 

Discussions similaires

Statistiques des forums

Discussions
311 725
Messages
2 081 940
Membres
101 845
dernier inscrit
annesof