Ameliorer le temps d'execution d'une macro

[M@rion]

Bonjour,

J'ai une macro que j'ai essayé d'optimiser mais elle met quand même 2 minutes à s'éxecuter (Pour environ 3000 lignes).
J'aimerais passer sous la barre des 15-20 secondes.

La voici :

Public Sub Valider_Click()

    ToutDemasquer

    Dim BDF, BDF2, BDF3 As Worksheet
    Dim l As Range
    Dim t_prem As Range, t_dern As Range
    Dim Unique As New Collection
    Dim Valeur As Range
    
    Application.ScreenUpdating = False
    
    'TextBoxDateSyn
    
    If TextBoxDateSyn.Value = "" Then
        MsgBox "Date vide.", vbCritical + vbOKOnly, "Erreur"
        TextBoxDateSyn.Value = ""
        TextBoxDateSyn.SetFocus
        Exit Sub
    End If
    If Not IsDate(TextBoxDateSyn.Value) Then
        MsgBox "Date incorrecte.", vbCritical + vbOKOnly, "Erreur"
        TextBoxDateSyn.Value = ""
        TextBoxDateSyn.SetFocus
        Exit Sub
    Else
        TextBoxDateSyn.Value = Format("01/" & TextBoxDateSyn.Value, "MM/YYYY")
    End If
    
    DateSyn = TextBoxDateSyn.Value
    PremColonne = PremDom()
    ' Création de la nouvelle feuille
    NomNewSheet = InsererFeuille(DateSyn)
    
    Set BDF = Worksheets("BDD")
    Set BDF2 = Worksheets("Table")
    Set BDF3 = Worksheets(NomNewSheet)
    Set t_prem = BDF.Cells(7, PremColonne)
    Set t_dern = BDF.Range("XFD7").End(xlToLeft)
    DernLigne = BDF2.Range("G" & Rows.Count).End(xlUp).Row
    
    Application.CutCopyMode = False
    Sheets("Synthese type").Cells.Copy
    BDF3.Range("A1").Select
    ActiveSheet.Paste
    
    BDF.Activate
    Range("A10").Select
    Range(Selection, Selection.End(xlDown)).Copy
    BDF3.Select
    Range("A7").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("A7", Selection.End(xlDown)).Select
    Application.CutCopyMode = False
    ' Mise en forme du tableau
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlDash
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
                
    PremColVide = Cells(5, 16000).End(xlToLeft).Offset(0, 1).Column
    
    ' Récupère les formations pour la liste multichoix
    On Error Resume Next
    'boucle sur les cellules de la ligne 1
    For Each l In Range(t_prem, t_dern)
    'Stocke les données dans une collection
    '(La collection n'accepte que des données uniques et permet donc
    ' de filtrer facilement les doublons).
    Unique.Add l, CStr(l)
    Next l
    On Error GoTo 0
    'Boucle sur le contenu de la collection pour alimenter la ListBox
    For Each Valeur In Unique
        j = 4
        While j <= DernLigne
            If BDF2.Range("G" & j).Value = Valeur Then
                ' Rajoute les colonnes stages a la fin du tableau
                Cells(5, 16000).End(xlToLeft).Offset(0, 1).Value = Valeur
                Cells(5, 16000).End(xlToLeft).Offset(1, 0).Value = BDF2.Range("E" & j).Value
            End If
            j = j + 1
        Wend
    Next Valeur
    
    ' Suppression des colonnes stages doublons
    Dercolonne = Range("XFD5").End(xlToLeft).Column
    PremColVide2 = PremColVide + 1
    While PremColVide <= Dercolonne
        While PremColVide2 <= Dercolonne
            If Cells(6, PremColVide).Value = Cells(6, PremColVide2).Value Then
                LettreColonne = Split(Cells(6, PremColVide2).Address, "$")(1)
                Columns(LettreColonne & ":" & LettreColonne).Delete Shift:=xlToLeft
                GoTo 1
            End If
        PremColVide2 = PremColVide2 + 1
1        Wend
        PremColVide = PremColVide + 1
    Wend
    
    PremColonneSyn = PremDomSyn()
    
    ' Mise en forme de la 2eme partie du tableau (Stages)
    Cells(5, PremColonneSyn).Select
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlDash
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlDash
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With

    ' Création et remplissage des colonnes de CTVs
    If PremColonne > 16 Then
        a = 14
        While a < PremColonne - 3
            LCol = Split(Cells(6, a).Address, "$")(1)
            Columns(LCol & ":" & LCol).Select
            Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
            Worksheets("BDD").Cells(8, a + 3).Copy
            Worksheets(NomNewSheet).Cells(5, a).Select
            ActiveSheet.Paste
            Range(Cells(5, a), Cells(6, a)).Select
            With Selection
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlBottom
                .WrapText = False
                .Orientation = 90
                .AddIndent = False
                .IndentLevel = 0
                .ShrinkToFit = False
                .ReadingOrder = xlContext
                .MergeCells = True
            End With
            With ActiveCell.Characters(Start:=1, Length:=11).Font
                .Name = "Calibri"
                .FontStyle = "Normal"
                .Size = 9
                .Strikethrough = False
                .Superscript = False
                .Subscript = False
                .OutlineFont = False
                .Shadow = False
                .Underline = xlUnderlineStyleNone
                .ThemeColor = xlThemeColorLight1
                .TintAndShade = 0
                .ThemeFont = xlThemeFontMinor
            End With
            Selection.Borders(xlDiagonalDown).LineStyle = xlNone
            Selection.Borders(xlDiagonalUp).LineStyle = xlNone
            With Selection.Borders(xlEdgeLeft)
                .LineStyle = xlDash
                .ColorIndex = 0
                .TintAndShade = 0
                .Weight = xlThin
            End With
            With Selection.Borders(xlEdgeTop)
                .LineStyle = xlContinuous
                .ColorIndex = 0
                .TintAndShade = 0
                .Weight = xlMedium
            End With
            With Selection.Borders(xlEdgeBottom)
                .LineStyle = xlContinuous
                .ColorIndex = 0
                .TintAndShade = 0
                .Weight = xlMedium
            End With
            With Selection.Borders(xlEdgeRight)
                .LineStyle = xlContinuous
                .ColorIndex = 0
                .TintAndShade = 0
                .Weight = xlMedium
            End With
            Selection.Borders(xlInsideVertical).LineStyle = xlNone
            Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
            
            b = 0
            DateSynF = Format("01/" & DateSyn, "MM/YYYY")
            DerLi = Worksheets("BDD").Range("A" & Rows.Count).End(xlUp).Row
            ' Remplissage de la colonne créée
            While b <= DerLi - 9
                If Worksheets("BDD").Cells(10 + b, a + 3).Value <> "" Then
                    DateTest = Format(Worksheets("BDD").Cells(10 + b, a + 3).Value, "MM/YYYY")
                    If CDate(DateTest) > CDate(DateSynF) Then
                        Worksheets(NomNewSheet).Cells(7 + b, a).Value = "P"
                        Worksheets(NomNewSheet).Cells(7 + b, a).Select
                        With Selection
                        .HorizontalAlignment = xlCenter
                        .VerticalAlignment = xlCenter
                        .WrapText = False
                        .Orientation = 0
                        .AddIndent = False
                        .IndentLevel = 0
                        .ShrinkToFit = False
                        .ReadingOrder = xlContext
                        .MergeCells = False
                        End With
                    Else
                        Worksheets(NomNewSheet).Cells(7 + b, a).Value = "X"
                        Worksheets(NomNewSheet).Cells(7 + b, a).Select
                        With Selection
                        .HorizontalAlignment = xlCenter
                        .VerticalAlignment = xlCenter
                        .WrapText = False
                        .Orientation = 0
                        .AddIndent = False
                        .IndentLevel = 0
                        .ShrinkToFit = False
                        .ReadingOrder = xlContext
                        .MergeCells = False
                        End With
                    End If
                End If
                b = b + 1
            Wend
            a = a + 1
        Wend
    End If

    Call TraitementDates(DateSyn, NomNewSheet)
    
    DerLiSyn = Range("A" & Rows.Count).End(xlUp).Row
    DerColSyn = Range("XFD6").End(xlToLeft).Column
    LDerColSyn = Split(Cells(9, DerColSyn).Address, "$")(1)
    
    'Mise en forme final du tableau
    ActiveSheet.ListObjects.Add(xlSrcRange, Range("$A$7:$" & LDerColSyn & "$" & DerLiSyn), , xlNo).Name = NomNewSheet
    ActiveSheet.ListObjects(NomNewSheet).TableStyle = "TableStyleLight2"
    ActiveSheet.ListObjects(NomNewSheet).ShowHeaders = False
    Rows("7:7").Select
    Selection.Delete Shift:=xlUp
    Range(Cells(5, 1), Cells(6, DerColSyn)).style = "40 % - Accent5"
    ' Fige la premiere colonne
    With ActiveWindow
        .SplitColumn = 1
        .SplitRow = 0
    End With
    ActiveWindow.FreezePanes = True
    
    PremColonneSyn = PremDomSyn()
    
    ' Création du regroupement pour les Cts
    Range(Cells(5, 2), Cells(6, PremColonneSyn - 1)).Columns.Group
    
    Range("A1").Select
    
    Application.ScreenUpdating = True
    
    Unload Me
    
End Sub

Elle fait appel à une autre grosse fonction :

Public Function TraitementDates(DateSyn, NomNewSheet)
    DateSynF = Format("01/" & DateSyn, "MM/YYYY")
    DerLi = Worksheets(NomNewSheet).Range("A" & Rows.Count).End(xlUp).Row
    DerLiTable = Worksheets("Table").Range("E" & Rows.Count).End(xlUp).Row
    Worksheets("BDD").Activate
    PremDomBDD = PremDom()
    DernColBDD = Range("XFD9").End(xlToLeft).Column
    Worksheets(NomNewSheet).Activate
    y = 0
    ' Parcours de chaque agent
    While y <= DerLi - 6
        If CDate(Worksheets("BDD").Range("D10").Offset(y, 0).Value) < CDate(DateSyn) And Worksheets("BDD").Range("D10").Offset(y, 0).Value <> "" Then
            GoTo 4
        End If
        x = 0
        ' Remplissage des CPFs
        While x <= 11
            If Worksheets("BDD").Range("E10").Offset(y, x).Value <> "" Then
                DateTest = Format(Worksheets("BDD").Range("E10").Offset(y, x).Value, "MM/YYYY")
                If CDate(DateTest) > CDate(DateSynF) Then
                    Worksheets(NomNewSheet).Range("B7").Offset(y, x).Value = "P"
                    Worksheets(NomNewSheet).Range("B7").Offset(y, x).Select
                    ' Mise en forme de la cellule
                    With Selection
                    .HorizontalAlignment = xlCenter
                    .VerticalAlignment = xlCenter
                    .WrapText = False
                    .Orientation = 0
                    .AddIndent = False
                    .IndentLevel = 0
                    .ShrinkToFit = False
                    .ReadingOrder = xlContext
                    .MergeCells = False
                    End With
                Else
                    Worksheets(NomNewSheet).Range("B7").Offset(y, x).Value = "X"
                    Worksheets(NomNewSheet).Range("B7").Offset(y, x).Select
                    With Selection
                    .HorizontalAlignment = xlCenter
                    .VerticalAlignment = xlCenter
                    .WrapText = False
                    .Orientation = 0
                    .AddIndent = False
                    .IndentLevel = 0
                    .ShrinkToFit = False
                    .ReadingOrder = xlContext
                    .MergeCells = False
                    End With
                End If
            End If
            x = x + 1
        Wend
        Z = PremDomSyn()
        Dercolonne = Range("XFD5").End(xlToLeft).Column
        ' Remplissage des stages
        ' Parcours de chaque colonne stage de la synthèse
        While Z <= Dercolonne
        LiDebTab = 4
            ' Parcours de chaques lignes de stage de la table
            While LiDebTab <= DerLiTable
                ' Test code stage de la ligne dans la table = code stage de la colonne en question de la synthèse
                If Worksheets("Table").Range("E" & LiDebTab).Value = Cells(6, Z).Value Then
                    ColBDD = PremDomBDD
                    ' Parcours de chaque colonne de la BDD pour voir si l'agent à les CTs requisent pour annimer le stage et son niveau
                    While ColBDD <= DernColBDD
                        ' Test code CTs dans la table = code CTs dans la BDD
                        If Worksheets("Table").Range("F" & LiDebTab).Value = Worksheets("BDD").Cells(8, ColBDD).Value Then
                            ' Test et écrit, dans la cellule de la synthèse, le niveau à l'aide des if suivants et est mis à jour si le niveau est inférieur
                            If Worksheets("BDD").Cells(10, ColBDD).Offset(y, 2).Value <> "" And CDate(Worksheets("BDD").Cells(10, ColBDD).Offset(y, 2).Value) < CDate(DateSynF) And (Cells(7 + y, Z) = "" Or Cells(7 + y, Z).Value = "XX") Then
                                Cells(7 + y, Z).Value = "XX"
                                Cells(7 + y, Z).Select
                                With Selection
                                .HorizontalAlignment = xlCenter
                                .VerticalAlignment = xlCenter
                                .WrapText = False
                                .Orientation = 0
                                .AddIndent = False
                                .IndentLevel = 0
                                .ShrinkToFit = False
                                .ReadingOrder = xlContext
                                .MergeCells = False
                                End With
                            ElseIf Worksheets("BDD").Cells(10, ColBDD).Offset(y, 1).Value <> "" And CDate(Worksheets("BDD").Cells(10, ColBDD).Offset(y, 1).Value) < CDate(DateSynF) And (Cells(7 + y, Z) = "" Or Cells(7 + y, Z).Value = "XX" Or Cells(7 + y, Z).Value = "X") Then
                                Cells(7 + y, Z).Value = "X"
                                Cells(7 + y, Z).Select
                                With Selection
                                .HorizontalAlignment = xlCenter
                                .VerticalAlignment = xlCenter
                                .WrapText = False
                                .Orientation = 0
                                .AddIndent = False
                                .IndentLevel = 0
                                .ShrinkToFit = False
                                .ReadingOrder = xlContext
                                .MergeCells = False
                                End With
                            ElseIf Worksheets("BDD").Cells(10, ColBDD).Offset(y, 0).Value <> "" And CDate(Worksheets("BDD").Cells(10, ColBDD).Offset(y, 0).Value) < CDate(DateSynF) And (Cells(7 + y, Z) = "" Or Cells(7 + y, Z).Value = "XX" Or Cells(7 + y, Z).Value = "X" Or Cells(7 + y, Z).Value = "P") Then
                                Cells(7 + y, Z).Value = "P"
                                Cells(7 + y, Z).Select
                                With Selection
                                .HorizontalAlignment = xlCenter
                                .VerticalAlignment = xlCenter
                                .WrapText = False
                                .Orientation = 0
                                .AddIndent = False
                                .IndentLevel = 0
                                .ShrinkToFit = False
                                .ReadingOrder = xlContext
                                .MergeCells = False
                                End With
                            ElseIf Worksheets("BDD").Cells(10, ColBDD).Offset(y, 2).Value = "" And Worksheets("BDD").Cells(10, ColBDD).Offset(y, 1).Value = "" And Worksheets("BDD").Cells(10, ColBDD).Offset(y, 0).Value = "" Then
                                Cells(7 + y, Z).Value = ""
                                GoTo 5
                            End If
                        End If
                    ColBDD = ColBDD + 3
                    Wend
                End If
            LiDebTab = LiDebTab + 1
            Wend
5        Z = Z + 1
        Wend
4        y = y + 1
    Wend
    
    
End Function

Merci d'avance à tous ceux qui auront fait l'effort de me lire, je suis consciente qu'un tel pavé ne doit pas être agréable à regarder.

Je suis ouverte à toutes pistes qui me permetterais d'avancer.

Cordialement,
M@rion

 

[pierrejean]

Re : Ameliorer le temps d'execution d'une macro

Bonjour M@rion

La seule piste valable pour moi est un fichier exemple avec quelques lignes sur les 3000 rendues anonymes
, accompagné d'une explication et avec le résultat attendu de ces codes

 

[M@rion]

Re : Ameliorer le temps d'execution d'une macro

Bonjour,

Merci de ta réponse rapide.

Voici le fichier avec seulement la macro lente et des données non confidentielle.
Etant donnée que sur ce fichier de démo il n'y a qu'une dizaine de ligne, la macro est instantanée.

La macro récupère des dates et en fonctions de celle-ci, remplie un tableau sur une autre feuille.

Encore merci pour ton aide.

Cordialement,
M@rion

 

[pierrejean]

Re : Ameliorer le temps d'execution d'une macro

Re

Peux-tu être plus explicite sur la façon de remplir le 2eme tableau
En effet il ne sera probablement pas possible d’accélérer sans un changement radical du code (utilisation de tableaux entre autre)

 

[M@rion]

Re : Ameliorer le temps d'execution d'une macro

Bonjour,

Je craignais cette réponse.

Donc dans un premier temps je nomme les colonnes du tableau en parcourant la colonne stage de la "table" (feuille masquée) correspondant aux domaines sélectionnés dans la "BDD". Mais c'est lors du remplissage des "codes stages" que le temps est trop long. Pour les remplir je regarde dans la "table" quel sont les CTs nécessaire à un code stage et je rempli le tableau en fonction du niveau général. Le niveau général pour un stage est donné par le niveau minimum dans une CT.

Voila j'espère avoir été compréhensible et pas trop synthétique.

Cordialement,
M@rion

 

[pierrejean]

Re : Ameliorer le temps d'execution d'une macro

Re

Peux-tu mieux préciser les critères conduisant à des x p xx .....
je n'ai pas réussi à interpréter ton code

 

[M@rion]

Re : Ameliorer le temps d'execution d'une macro

Bonjour,

Dans le fichier BDD une ct possède 3 colonnes. Si la date de la synthèse est inférieur à celle des 3 colonnes alors on met rien dans la colonne stage de la synthèse, si elle est supérieur à la première mais inférieur aux deux autres on met "p", si elle est supérieur aux 2 premières mais inférieur à la dernière, on met x et si elle est supérieur aux 3 on met XX. Mais un même stage peut dépendre de plusieurs Cts donc j'écris dans la synthèse le plus petit niveau trouvé ( "vide" < p < x < xx).

En espérant avoir été assez compréhensible.

Cordialement,
M@rion