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