XL 2016 exécution macro ... très très longue

halecs93 · 5 Février 2025

Bonjour à toutes et à tous.....

J'ai créé un classeur qui me permet de générer des setlists de chansons. Pour cela, je sélectionne grâce à des cases à cocher des titres. Une fois fait, j'exécute la macro (bouton "Générer la setlist".... et c'est très long.... je pense qu'il est possible d’accélérer plus que grandement son exécution....

Alors...un grand grand merci.

sylvanu · 5 Février 2025

Bonjour Halec,
Lire écrire dans des cellules est très long, surtout s'il y a beaucoup de cellules.
Il vaut mieux passer par des arrays. Un en entrée, et un en sortie.
A la fin on restitue l'array dans la feuille.
En PJ un essai ( je suppose la feuille NetList existante )

VB:

Sub GenererSetlist()
    Dim Tablo, Sortie, N%, i%
    Tablo = [LISTE_CHANSONS]                    ' Toute la liste dans l'array Tablo
    ReDim Sortie(1 To UBound(Tablo), 1 To 4)    ' Ondimmensionne le tableau de sortie ( taille idem que tableau d'entrée )
    N = 1
    For i = 1 To UBound(Tablo)                  ' On remplit le tableau de sortie
        If Tablo(i, 4) = True Then
            Sortie(N, 1) = Tablo(i, 1)
            Sortie(N, 2) = Tablo(i, 2)
            Sortie(N, 3) = Tablo(i, 5)
            Sortie(N, 4) = Tablo(i, 6)
            N = N + 1
        End If
    Next i
    Sheets("SETLIST").[A:D].ClearContents       ' On efface la liste présente et on met la liste trouvée.
    Sheets("SETLIST").[A1].Resize(UBound(Sortie, 1), UBound(Sortie, 2)) = Sortie
End Sub

Sur mon vieux XL2007 je met 0.25s pour une liste de 136 titres.
Pouvez vous essayer ?

halecs93 · 5 Février 2025

sylvanu à dit:

Bonjour Halec,
Lire écrire dans des cellules est très long, surtout s'il y a beaucoup de cellules.
Il vaut mieux passer par des arrays. Un en entrée, et un en sortie.
A la fin on restitue l'array dans la feuille.
En PJ un essai ( je suppose la feuille NetList existante )

VB:

Sub GenererSetlist()
    Dim Tablo, Sortie, N%, i%
    Tablo = [LISTE_CHANSONS]                    ' Toute la liste dans l'array Tablo
    ReDim Sortie(1 To UBound(Tablo), 1 To 4)    ' Ondimmensionne le tableau de sortie ( taille idem que tableau d'entrée )
    N = 1
    For i = 1 To UBound(Tablo)                  ' On remplit le tableau de sortie
        If Tablo(i, 4) = True Then
            Sortie(N, 1) = Tablo(i, 1)
            Sortie(N, 2) = Tablo(i, 2)
            Sortie(N, 3) = Tablo(i, 5)
            Sortie(N, 4) = Tablo(i, 6)
            N = N + 1
        End If
    Next i
    Sheets("SETLIST").[A:D].ClearContents       ' On efface la liste présente et on met la liste trouvée.
    Sheets("SETLIST").[A1].Resize(UBound(Sortie, 1), UBound(Sortie, 2)) = Sortie
End Sub

Sur mon vieux XL2007 je met 0.25s pour une liste de 136 titres.
Pouvez vous essayer ?

Merci.... super...en effet...à un petit détail près.... la macro n'a pas conservé le formatage (HH:mm) qu'il y a en colonne F....

AU cas où la feuille SETLIST n'existe pas, j'ai modifié le code ainsi

VB:

Sub GenererSetlist()
    Dim Tablo, Sortie, N%, i%
    Dim ws As Worksheet

    Tablo = [LISTE_CHANSONS]                    ' Toute la liste dans l'array Tablo
    ReDim Sortie(1 To UBound(Tablo), 1 To 4)    ' On redimensionne le tableau de sortie (taille idem que tableau d'entrée)
    N = 1
    
    ' Vérifier si la feuille SETLIST existe, sinon la créer
    On Error Resume Next
    Set ws = Sheets("SETLIST")
    On Error GoTo 0
    
    If ws Is Nothing Then
        ' Si la feuille n'existe pas, on la crée
        Set ws = Sheets.Add(After:=Sheets(Sheets.Count))
        ws.Name = "SETLIST"
    End If
    
    ' Remplir le tableau de sortie
    For i = 1 To UBound(Tablo)                  ' On remplit le tableau de sortie
        If Tablo(i, 4) = True Then
            Sortie(N, 1) = Tablo(i, 1)
            Sortie(N, 2) = Tablo(i, 2)
            Sortie(N, 3) = Tablo(i, 5)
            Sortie(N, 4) = Tablo(i, 6)
            N = N + 1
        End If
    Next i
    
    ws.[A:D].ClearContents       ' On efface la liste présente et on met la liste trouvée.
    ws.[A1].Resize(UBound(Sortie, 1), UBound(Sortie, 2)) = Sortie
End Sub

sylvanu · 5 Février 2025

Re,
Une V2.
J'ai introduit ma macro dans la votre, et la colonne D en format horaire.

halecs93 · 5 Février 2025

sylvanu à dit:
Re,
Une V2.
J'ai introduit ma macro dans la votre, et la colonne D en format horaire.

Sacrée accélération..... cependant, si je peux me permettre, dans la macro originale, la setlist créée ne reprenait ne reprenait pas la numérotation de la feuille LISTE, mais générait sa propre numérotation... de 1 à...etc... merci beaucoup

sylvanu · 5 Février 2025

Il suffit juste de modifier cette ligne :

VB:

Sortie(N, 1) = N

mapomme · 5 Février 2025

Bonsoir à tous,

halecs93 à dit:
et c'est très long....

Votre macro fonctionne et elle est assez rapide pour le nombre de lignes à traiter (mais moins rapide que celle de @sylvanu).

Votre classeur s'est développé au fur et à mesure et sans doute par mégarde vous avez dupliqué le code du module 2 dans le module de ThisWorkbook pour l'évènement Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range).

Donc que se passe-t-il ?

vous lancez via le bouton GenererSetlist du module2 (exécution n°1)
à un moment donné, vous modifiez des valeurs de la feuille destination (effacement ou affectation d'une valeur à une cellule)
VBA détecte ces changements, met en suspend GenererSetlist du module2 qui est en cours d'exécution et lance la procédure évènementielle Workbook_SheetChange.
dans cette seconde exécution, vous modifiez encore une fois les données de la feuille cible
VBA détecte une nouvelle fois ces changements, met en suspend l'exécution en cours et relance la procédure évènementielle Workbook_SheetChange
dans cette troisième exécution, vous modifiez encore une fois les données de la feuille cible
VBA détecte une nouvelle fois ces changements, met en suspend l'exécution en cours et relance la procédure évènementielle Workbook_SheetChange
et ainsi de suite...

Vous lancez donc des exécutions successives et empilez les exécutions en attente de terminaison. Ca ne peut que très mal finir.

Supprimez simplement le code du module de ThisWorkbook dans votre classeur initial et tout rentrera dans l'ordre.
Il n'y aura qu'une seule exécution de GenererSetlist du module2.

halecs93 · 5 Février 2025

sylvanu à dit:
Il suffit juste de modifier cette ligne :

VB:

Sortie(N, 1) = N

Un grand merci....

halecs93 · 5 Février 2025

mapomme à dit:
Bonsoir à tous,

Votre macro fonctionne et elle est assez rapide pour le nombre de lignes à traiter (mais moins rapide que celle de @sylvanu).

Votre classeur s'est développé au fur et à mesure et sans doute par mégarde vous avez dupliqué le code du module 2 dans le module de ThisWorkbook pour l'évènement Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range).

Donc que se passe-t-il ?

vous lancez via le bouton GenererSetlist du module2 (exécution n°1)

à un moment donné, vous modifiez des valeurs de la feuille destination (effacement ou affectation d'une valeur à une cellule)

VBA détecte ces changements, met en suspend GenererSetlist du module2 qui est en cours d'exécution et lance la procédure évènementielle Workbook_SheetChange.

dans cette seconde exécution, vous modifiez encore une fois les données de la feuilles cible

VBA détecte une nouvelle fois ces changements, met en suspend l'exécution en cours et relance la procédure évènementielle Workbook_SheetChange

dans cette troisième exécution, vous modifiez encore une fois les données de la feuilles cible

VBA détecte une nouvelle fois ces changements, met en suspend l'exécution en cours et relance la procédure évènementielle Workbook_SheetChange

et ainsi de suite...

Vous lancez donc des exécutions successives et empilez les exécutions en attente de terminaison. Ca ne peut que très mal finir.

Supprimez simplement le code du module de ThisWorkbook dans votre classeur initial et tout rentrera dans l'ordre.
Il n'y aura qu'une seule exécution de GenererSetlist du module2.

Bonsoir...et en effet.... classeur construit petit à petit, en tâtonnant 😉

sylvanu · 5 Février 2025

Bonsoir Mapomme,
Avec ma macro, Workbook_SheetChange ne s'exécute qu'une fois, donc ne perturbe pas le temps d'exécution.
Et on conserve la fonction d'ajout de case à cocher.

mapomme · 5 Février 2025

Bonsoir @sylvanu 😉,

sylvanu à dit:
Avec ma macro, Workbook_SheetChange ne s'exécute qu'une fois, donc ne perturbe pas le temps d'exécution.
Et on conserve la fonction d'ajout de case à cocher.

Oui mais le problème n'est pas l'écriture de la macro mais une anomalie de logique au niveau du codage.
La cause première de la lenteur du code de @halecs93 n'est pas son écriture mais bien la duplication inutile du code de la procédure dans un évènement Change de ThisWorkbook.

D'ailleurs si on supprime le code injustifié de ThisWorkbook, ta macro est aussi plus rapide.

Phil69970 · 5 Février 2025

Bonjour à tous

@halecs93
Ma version utilisant le TS 😉
Tu cliques dans la colonne "case pour cocher ou non la chanson
J'ai fait un grand ménage de l'inutile 🤣
Et le fichier est passé de 380 Ko à 80 Ko !!!

Merci de ton retour

halecs93 · 5 Février 2025

Phil69970 à dit:
Bonjour à tous

@halecs93
Ma version utilisant le TS 😉
Tu cliques dans la colonne "case pour cocher ou non la chanson
J'ai fait un grand ménage de l'inutile 🤣
Et le fichier est passé de 380 Ko à 80 Ko !!!

Merci de ton retour

Bonsoir...très intéressant de ne pas dépendre de cases à cocher..... il faudrait revoir le code...pour la remise à zéro....et la création de l'onglet SETLIST si il n'existe pas 😉... Mais merci aussi, en effet (j'adore ces solutions multiples)

Phil69970 · 5 Février 2025

@halecs93

halecs93 à dit:
il faudrait revoir le code...pour la remise à zéro

Je pense que tu parles de "Tout décocher"

Voici la V2 .....

Pour la création de la feuille après le repas .....

Que cela soit la suppression des croix ou la copie sur l'autre feuille c'est quasi instantané !!!

halecs93 · 5 Février 2025

Phil69970 à dit:
@halecs93

Je pense que tu parles de "Tout décocher"

Voici la V2 .....

Pour la création de la feuille après le repas .....

Que cela soit la suppression des croix ou la copie sur l'autre feuille c'est quasi instantané !!!

Tout à fait...du coup.... petite modification du code si la feuille "SETLIST" n 'existe pas

VB:

Option Explicit

Sub Extraire()
    Application.ScreenUpdating = False
    Dim Ws1 As Worksheet, Ws2 As Worksheet, Derlig&, NbLig&, Titre
    Dim FiltreDateDebut As String, FiltreDateFin As String
    
    ' Vérifier si la feuille "Setlist" existe, sinon la créer
    On Error Resume Next
    Set Ws1 = Worksheets("Setlist")
    On Error GoTo 0
    If Ws1 Is Nothing Then
        Set Ws1 = ThisWorkbook.Worksheets.Add
        Ws1.Name = "Setlist"  ' Créer la feuille Setlist si elle n'existe pas
    End If
    
    ' Assurez-vous que la feuille "Liste" existe
    Set Ws2 = Worksheets("Liste")
    
    Ws1.Columns("A:E").Clear                         ' Facultatif Efface les valeurs dans la feuille Setlist
    Ws1.Columns("E:E").NumberFormat = "mm:ss"
    Titre = Array("N°", "TITRE", "CASE", "AMBIANCE", "DUREE")
    Ws1.Range("A1:E1") = Titre
    
    Range("T_Liste_Chansons[[#Headers],[Case]]").AutoFilter
    Range("T_Liste_Chansons").AutoFilter Field:=3, Criteria1:="X"
    
    Derlig = Ws1.Range("A" & Rows.Count).End(xlUp).Row + 1
    
    If Range("T_Liste_Chansons").ListObject.DataBodyRange Is Nothing Then
        MsgBox "Pas de chanson dans le tableau", vbInformation, "Problème"
        Exit Sub                                ' Tableau vide on sort
    End If
    
    If Range("T_Liste_Chansons").ListObject.ListColumns(1).Range.SpecialCells(xlCellTypeVisible).Count <= 1 Then
        MsgBox "Aucune ligne visible dans le tableau.", vbCritical, "Problème !"
        Range("T_Liste_Chansons[[#Headers],[Case]]").AutoFilter
        Exit Sub                                ' Filtre du tableau vide on sort
    Else
        NbLig = Range("T_Liste_Chansons").ListObject.ListColumns(1).DataBodyRange.SpecialCells(xlCellTypeVisible).Count
    End If
    
    Ws2.ListObjects("T_Liste_Chansons").DataBodyRange.SpecialCells(xlCellTypeVisible).Copy
    Ws1.Range("A" & Derlig).PasteSpecial Paste:=xlPasteValues
    
    Ws1.Columns("B:F").AutoFit
    Range("T_Liste_Chansons[[#Headers],[Case]]").AutoFilter
    
    If NbLig > 1 Then
        MsgBox NbLig & " lignes ont été copiées ... ", vbInformation, "Copie effectuée !"
    Else
        MsgBox NbLig & " ligne a été copiée ... ", vbInformation, "Copie effectuée !"
    End If

    ' Habillage
    Derlig = Ws1.Range("A" & Rows.Count).End(xlUp).Row
    Ws1.[A2] = 1: Ws1.Range("A2:A" & Derlig).DataSeries
    Ws1.Columns("C:C").Delete Shift:=xlToLeft
    Ws1.Range("A:F").Borders.LineStyle = xlNone
    Ws1.Range("A1").CurrentRegion.Borders.LineStyle = xlContinuous
    'Ws1.Range("A1").Select
End Sub

Sub Decocher()
    Range("T_Liste_Chansons[Case]").ClearContents
End Sub

Que dire...merci aussi 🙂

XL 2016 exécution macro ... très très longue

XLDnaute Impliqué

Pièces jointes

XLDnaute Barbatruc

Pièces jointes

XLDnaute Impliqué

XLDnaute Barbatruc

Pièces jointes

XLDnaute Impliqué

XLDnaute Barbatruc

Pièces jointes

XLDnaute Barbatruc

XLDnaute Impliqué

XLDnaute Impliqué

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

Pièces jointes

XLDnaute Impliqué

XLDnaute Barbatruc

Pièces jointes

XLDnaute Impliqué

Discussions similaires

Nous accordons de l'importance à votre vie privée