Tri des feuilles selon 3 valeurs

  • Initiateur de la discussion Initiateur de la discussion marie49
  • Date de début Date de début

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

marie49

XLDnaute Occasionnel
Bonjour,
J'ai réalisé une macro qui permet de faire un tri des feuilles selon 3 valeurs se trouvant sur chaque feuille.

Cette macro marche bien sauf que si on fait plusieurs tris à la suite, son exécution est longue. Cela commence même au deuxième tri.

Quelqu'un aurait-il une idée pour éviter cette lenteur?

Voici le code :
Code:
Sub TriFiche()


'Cette méthode utilise la feuille Menu du fichier "Tri des feuilles selon 3 valeurs.xls" pour
'insérer le nom des feuilles avec le module, le niveau et le numéro d'ordre
' sur les lignes à partir de la ligne 40
'le tri se fait d'abord sur ces lignes
'Ensuite on répercute l'ordre avec les différentes feuilles
'A la fin on met un lien vers chaque feuille

On Error Resume Next
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False


Dim i, j, NbrLig As Integer
Dim A As String
Dim Rng As Range


With Workbooks("Tri des feuilles selon 3 valeurs.xls")
    Application.StatusBar = "Début du tri des fiches"
    
    'suppression des lignes dans le fichier menu à partir de la ligne 40
    NbrLig = .Sheets("Menu").Range("B35536").End(xlUp).Row
    .Sheets("Menu").Activate
    ActiveSheet.Range("A40:IV" & NbrLig).Select
    Application.EnableEvents = False 'désactive les actions automatiques du fichier ficenseignement
    Selection.Delete Shift:=xlUp
    
    For i = 2 To .Worksheets.Count 'Ecrit dans la feuille Menu le nom des feuilles, le module, l'ue et l'ordre
        .Sheets("Menu").Cells(i + 38, 1).Value = .Worksheets(i).Name 'le nom de la feuille
        .Sheets("Menu").Cells(i + 38, 4).Value = .Worksheets(i).Cells(4, 3).Value 'le module
        .Sheets("Menu").Cells(i + 38, 2).Value = .Worksheets(i).Cells(3, 9).Value 'le niveau
        .Sheets("Menu").Cells(i + 38, 3).Value = .Worksheets(i).Cells(1, 9).Value 'le numéro d'ordre
    
    Next i
    
    'réalisation du tri dans le fichier Menu
    Application.StatusBar = "Début du tri des fiches;partie2"

    j = i + 37
    A = "A40:D" & j
    .Sheets("Menu").Activate
    ActiveSheet.Range(A).Select
    'ordre de tri : Module,Niveau et Numéro d'ordre
    Selection.Sort Key1:=Range("D40"), Order1:=xlAscending, Key2:=Range("B40" _
        ), Order2:=xlAscending, Key3:=Range("C40" _
        ), Order3:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _
        False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2 _
        :=xlSortNormal
    
    'Déplacement des feuilles selon leur place dans le tri
    Application.StatusBar = "Déplacement des feuilles  ; partie3"

    For i = .Worksheets.Count To 2 Step -1
        A = .Sheets("Menu").Cells(i + 38, 1).Value
        .Sheets(A).Move After:=Sheets(i - 1)
    Next i
    
    'Ajout d'un lien direct vers la feuille concernée dans la liste de la feuille Menu
    Application.StatusBar = "Trifiche: ajout d'un lien  ; partie4"

    For i = 2 To .Worksheets.Count
        .Sheets("Menu").Hyperlinks.Add Anchor:=.Sheets("Menu").Cells(i + 38, 1), Address:="", SubAddress:= _
        .Sheets("Menu").Cells(i + 38, 1).Value & "!A1", TextToDisplay:=.Sheets("Menu").Cells(i + 38, 1).Value
    Next i
 
    .Sheets("Menu").Select
    Application.EnableEvents = True
 
    .Save
End With
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

End Sub


Je me suis déjà inspiré de ce que j'ai trouvé sur le forum...en passant par une feuille menu où je met toutes les informations permettant de faire le tri et ensuite je répercute l'ordre des feuilles dans le fichier.

Merci de votre aide

Marie
 
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

Réponses
5
Affichages
239
  • Question Question
XL 2021 listbox
Réponses
18
Affichages
285
Réponses
5
Affichages
232
Réponses
4
Affichages
177
  • Question Question
XL 2021 VBA excel
Réponses
4
Affichages
171
Retour