Optimisation temps d'exécution de macro

Question

J'ai rencontré un problème dans mon fichier excel avec macro. Mon code fonctionne comme je le voudrai pour créer mes documents. Cependant le temps d'exécution est trop long surtout sur le dernier module dont j'ai besoin (Code_Partie5_BD3). Pouvez vous m'aider a optimiser mon code ? De plus j'ai 4 liaisons que je n'arrive pas a supprimer. Je voulais joindre un fichier mais celui ci est trop volumineux. Comment puis je faire ? je vous joins le code quand meme. Dim dlg&, i&, ht&, Fin&, x&, y& 'Déclarer variable Dim CEL, PLAGE As Range 'Déclarer variable Sub RempBD3() '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' '''''''Après avoir rempli les cellules de la feuille'''''''' '''''''''''''''''''Cliquer sur le bouton'''''''''''''''''''' '''''''Renvoie les valeurs de la feuille BD3 vers AR'''''''' '''''''Renvoie les valeurs de la feuille BD3 vers FTI''''''' '''''''Renvoie les valeurs de la feuille BD3 vers FTF''''''' '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Application.ScreenUpdating = False Application.EnableEvents = False With Sheets("BD3") 'Dans la feuille BD3 Worksheets("BD3").Select 'Activer onglet dlg = Sheets("BD3").Range("B" & Rows.Count).End(xlUp).Row 'Calcul dernière ligne .Rows("9:" & dlg).Copy Sheets("BD1").Rows("9:9") 'Renvoie les valeurs vers BD1 Application.CutCopyMode = False 'Fin du mode copier couper coller End With Sheets("BD3").Copy After:=Sheets(3) 'Copie de l'onglet BD With Sheets("BD3 (2)") 'Dans la feuille BD3 (2) Worksheets("BD3 (2)").Visible = True 'Afficher onglet Worksheets("BD3").Visible = False 'Fermer onglet Sheets("BD3 (2)").Select 'Activer la feuille ActiveWindow.FreezePanes = False 'Libérer les volets ActiveSheet.DrawingObjects.Delete 'Supprimer les objets .Columns("L:M").Delete 'Supprimer colonnes L et M .Columns("A:A").Cut 'Couper colonne A .Columns("P:P").Insert shift:=xlToRight 'Insérer Application.CutCopyMode = False 'Fin du mode copier couper coller .PageSetup.Orientation = xlLandscape 'Mettre en format paysage .PageSetup.PaperSize = xlPaperA4 'Mettre au format A4 .PageSetup.LeftMargin = Application.InchesToPoints(0) 'Valeur marge gauche .PageSetup.RightMargin = Application.InchesToPoints(0) 'Valeur marge droite .PageSetup.TopMargin = Application.InchesToPoints(0.15748031496063) 'Valeur marge haut .PageSetup.BottomMargin = Application.InchesToPoints(1) 'Valeur marge bas .PageSetup.HeaderMargin = Application.InchesToPoints(0.31496062992126) 'Valeur marge en tete .PageSetup.FooterMargin = Application.InchesToPoints(0.31496062992126) 'Valeur marge pied de page Sheets("ModAR").Rows("10:17").Copy 'Copier Sheets("BD3 (2)").Rows("1:1").Select 'Collage spécial Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _ SkipBlanks:=False, Transpose:=False ActiveSheet.Paste Application.CutCopyMode = False 'Fin du mode copier couper coller ActiveWindow.View = xlPageLayoutView 'Affichage en mode Page ActiveWindow.View = xlNormalView 'Affichage en mode normal dlg = .Range("A" & Rows.Count).End(xlUp).Row 'Calcul dernière ligne For i = 9 To dlg 'Pour chaque ligne .Rows(i).AutoFit 'Ajuster automatiquement la hauteur de ligne ht = Application.WorksheetFunction.RoundUp((.Rows(i).RowHeight / 15), 0) * 15 'Calcul valeur arrondie supérieur de la hauteur .Rows(i).RowHeight = ht 'Mettre la valeur de la hauteur à ht Next i For i = 10 To dlg + 10000 'Pour les lignes de 10 à la dernière +5000 A = .Range("O" & i).Value 'Valeur de la variable e = .Range("O" & i - 1).Value 'Valeur de la variable If A = "" Then Exit For 'Sortir si vide If A &lt;&gt; e Or .Rows(i).PageBreak &lt;&gt; xlNone Then 'Si valeur a différente de valeur e ou saut de page présent Sheets("ModAR").Rows("20:26").Copy 'Copier .Rows(i).Insert shift:=xlDown 'Insérer Application.CutCopyMode = False 'Fin du mode copier couper coller Sheets("BD3 (2)").Select 'Activé onglet .HPageBreaks.Add before:=Range("A" & i) 'Ajout saut de page ActiveWindow.View = xlPageLayoutView 'Affichage en mode Page ActiveWindow.View = xlNormalView 'Affichage en mode normal i = i + 7 'Ajout de lignes à la variable End If Next i dlg = .Range("A" & Rows.Count).End(xlUp).Row + 1 'Calcul dernière ligne .HPageBreaks.Add before:=Rows(dlg) 'Ajout saut de page For i = 1 To .HPageBreaks.Count 'Pour les sauts de page de l'onglet Valeur = Cells(.HPageBreaks(i).Location.Row - 1, 15) 'Valeur = cellule à l'intersection de la colonne M, ligne du saut de page -1 Select Case i 'Selectionner le cas selon la valeur Case 1 ' I = 1 Set PLAGE = .Range(.Cells(1, 1), .Cells(.HPageBreaks(i).Location.Row - 1, 1)) 'PLAGE = B1:B & ligne saut de page -1 Case .HPageBreaks.Count + 1 'I = Dernier saut de page Set PLAGE = .Range(.Cells(.HPageBreaks(i).Location.Row, 1), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 1)) 'PLAGE = B & Ligne dernier saut de page & B & dernière ligne Case Else 'Dans tous les autres cas Set PLAGE = .Range(.Cells(.HPageBreaks(i - 1).Location.Row, 1), .Cells(.HPageBreaks(i).Location.Row - 1, 1)) 'PLAGE = B & saut de page I - 1 : B & Saut de page I - 1 ligne End Select For Each CEL In PLAGE 'Pour chaque cellule de la plage If CEL Like "*Numéro et nom*" Then 'Si contient numéro et nom .Cells(CEL.Row, 6) = Valeur 'Si la cellule est égal "*Numéro et nom*" alors on attribue la valeur If Len(.Range("G" & CEL.Row)) &gt; 64 Then 'Si longueur de text supérieur à 64 ht = Application.WorksheetFunction.RoundUp((.Rows(CEL.Row).RowHeight), 0) * 1.5 'Calcul valeur arrondie supérieur de la hauteur .Rows(CEL.Row).RowHeight = ht 'Mettre la valeur de la hauteur à ht .Rows(CEL.Row + 1).RowHeight = 10 'Mettre valeur de hauteur à 10 End If End If Next CEL Valeur1 = Cells(.HPageBreaks(i).Location.Row, 1) 'Valeur = cellule à l'intersection de la colonne M, ligne du saut de page -1 If Valeur1 = "" Then Exit For 'Si vide sortir Next i .Columns("O:O").Delete shift:=xlToLeft 'Suppression colonne Fin = .Range("A" & Rows.Count).End(xlUp).Row 'Calcul dernière ligne End With Worksheets("AR").Visible = True 'Afficher onglet With Sheets("AR") 'Dans la feuille AR Sheets("AR").Select 'Activer la feuille dlg = .Range("B" & Rows.Count).End(xlUp).Row + 2 'Calcul dernière ligne Sheets("BD3 (2)").Rows("1:" & Fin).Copy 'Copier .Rows(dlg).Insert shift:=xlDown 'Inserer Application.CutCopyMode = False 'Fin du mode copier couper coller For Each CEL In .Range("A10:A" & .UsedRange.Rows.Count) 'Pour chaque cellule de la colonne A If CEL.Value Like "*Titre du document*" Then 'Si la cellule contient Titre .HPageBreaks.Add before:=Rows(CEL.Row) 'Ajout saut de page End If Next CEL Application.DisplayAlerts = False 'Empecher affichage message d'erreur Sheets("BD3 (2)").Select 'Selectionner l'onglet BD2 (2) ActiveWindow.SelectedSheets.Delete 'Supprimer la selection Application.DisplayAlerts = True 'Remettre affichage message erreur Sheets("AR").Select 'Activer la feuille x = Sheets("AR").HPageBreaks.Count dlg = .Range("A" & Rows.Count).End(xlUp).Row + 2 Sheets("ModAR").Rows("1:5").Copy Sheets("AR").Rows(dlg) y = Sheets("AR").HPageBreaks.Count If y &gt; x Then Sheets("AR").Select 'Activer la feuille Sheets("ModAR").Rows("125:131").Copy .Rows(dlg - 2).Insert shift:=xlDown Fin = Sheets("PérimètreAR").Range("B" & Rows.Count).End(xlUp).Row .Range("F" & dlg + 1) = Sheets("PérimètreAR").Range("B" & Fin) If Len(.Range("G" & dlg + 1)) &gt; 64 Then ht = Application.WorksheetFunction.RoundUp((.Rows(dlg + 1).RowHeight), 0) * 1.5 .Rows(dlg + 1).RowHeight = ht .Rows(dlg + 2).RowHeight = 10 End If .HPageBreaks.Add before:=Rows(dlg - 2) End If x = Sheets("AR").HPageBreaks.Count Do While y = x dlg = .Range("A" & Rows.Count).End(xlUp).Row - 4 Sheets("AR").Rows(dlg).Select Selection.Insert shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove y = Sheets("AR").HPageBreaks.Count Loop Call PagAR 'Mise à jour pagination End With Call FTI 'Renvoie le code_partie41 Call PagFTI 'Pagination FTI Call FTF 'Renvoie le code_partie42 Call PagFTF 'Pagination FTF Application.ScreenUpdating = True Application.EnableEvents = True Worksheets("FTF").Visible = True 'Afficher onglet Worksheets("FTI").Visible = True 'Afficher onglet Worksheets("AR").Visible = True 'Afficher onglet Worksheets("PRT").Visible = True 'Afficher onglet Worksheets("BD3").Visible = False 'Masquer onglet End Sub Bien cordialement, Mika...

Rag02700 · Answer

Tu peux passer le calcul auto en manuel, puis le remettre en fin de procédure : Application.Calculation = xlCalculationManual Mais pour moi ce qui te bouffes un paquet de temps, ce sont tes insert de ligne en boucle .... Par exemple : For i = 10 To dlg + 10000 'Pour les lignes de 10 à la dernière +5000 A = .Range("O" & i).Value 'Valeur de la variable e = .Range("O" & i - 1).Value 'Valeur de la variable If A = "" Then Exit For 'Sortir si vide If A &lt;&gt; e Or .Rows(i).PageBreak &lt;&gt; xlNone Then 'Si valeur a différente de valeur e ou saut de page présent Sheets("ModAR").Rows("20:26").Copy 'Copier .Rows(i).Insert shift:=xlDown 'Insérer Si tu dois ajouter 5000 lignes ... Faut que tu revois ta méthodologie pour diminuer l'insertion des lignes...

BsAlv · Answer

Bonjour, je ne comprend pas tout ces pagebreaks, ils servent à quoi, imprimer ? vers PDF ? Le reste est trop complique pour lire et comprendre le but final. Vous n'avez pas un fichier avec une situation AVANT et APRES et une courte description...

BsAlv · Answer

Sauf pour imprimer, ces pagebreaks, ils servent à quelque chose ? Autrement, c'est plus facile de les créer (virtuellement) à ce moment. Imprimer, c'est PDF ou sur papier ? Un fichier exemplaire, ce n'est qu'une 10-20 règles ou une courte description de tout ce que cette macro fait...

BsAlv · Answer

Par exemple ajuster l'hauteur, ceci est déjà une amélioration, mais pourquoi choisir une hauteur de 15 au lieu du standard 14.25 ? une différence de +5 sec sur 1.000 lignes La macro "teste" ajuste en une fois toutes les lignes 9:1000 et puis vérifie si l'hauteur doit être ajuster en haut vers un multiple de rh. (Attention ce multiple ne peut pas être supérieur à 409) Sub teste() dlg = 1000 With ActiveSheet rh = 14.25 'plus tard changer ce 14.25 en 15 t = Timer .Rows("9:" & dlg).AutoFit 'en une fois, Ajuster automatiquement la hauteur de ligne For i = 9 To dlg 'Pour chaque ligne ht = Application.Min(409, WorksheetFunction.Ceiling_Math(.Rows(i).RowHeight, rh)) 'Calcul valeur arrondie supérieur de la hauteur If ht &gt; .Rows(i).RowHeight Then .Rows(i).RowHeight = ht 'seulement quand il est supérieur, Mettre la valeur de la hauteur à ht Next i MsgBox Format(Timer - t, "0.00") End With End Sub...

BsAlv · Answer

C'est difficile a dire où vous gagnerez le max du temps, mais si vous savez au minimum la duréé de chaque partie de cette macro. Vous pouvez ajouter ma macro MyTimers et les déclarations en haut et puis apres chaque partie faire un saute vers cette macro avec un numéro croissant. Après l'execution, vous pouvez choisir le plus grand et cherchez à eliminer du temps ou me dire cette partie est à améliorer . Vous pouvez déjà essayer avec la macro 'MaMacro", lancez-le, il y a 3 msgbox dedans, attendez un moment variable à chaque msgbox et voyez le résultat Public Timers(1 To 100, 1 To 4), iT Sub MaMacro() MesTimers 1, "début" MsgBox "maintenant la 1ière partie du macro" MesTimers 2, "après part1" MsgBox "maintenant la 2ière partie du macro" MesTimers 3, "après part2" MsgBox "maintenant la 3ieme partie du macro" MesTimers 4, "Fin" s = "" For i = LBound(Timers) To UBound(Timers) If Len(Timers(i, 4)) &gt; 0 Then s = s & vbLf & Format(Timers(i, 2), "0.0\s") & " " & Format(Timers(i, 3), "0.0\s") & " " & Timers(i, 4) End If Next If Len(s) &gt; 0 Then MsgBox Mid(s, 2) End Sub Sub MesTimers(Numéro, Texte) If LBound(Timers) &lt;= Numéro And Numéro &lt;= UBound(Timers) Then Timers(Numéro, 1) = Timer Timers(Numéro, 2) = Timer - Timers(1, 1) 'temps des le début If Numéro &gt; 1 Then Timers(Numéro, 3) = Timer - Timers(Numéro - 1, 1) Else Timers(1, 3) = 0 'temps pour cet element Timers(Numéro, 4) = Texte Else MsgBox "mauvaise indexe " & Numéro, vbInformation End If End Sub...

BsAlv · Answer

En annexe la macro initiale avec des lignes supplémentaires, x est un numéro croissant (de 1 à 100) et "Explication" est un texte qui explique ce que la partie précédente a fait. MesTimers x, "Explication" Après vous recevez un msgbox avec en première colonne le temps cumulatif, 2ième colonne le temps de cette partie et 3ième colonne l'explication. Maintenant cherchez le maximum dans la 2ième colonne, normallement on a une meilleur chance de gagner plus de temps avec celui-là...

BsAlv · Answer

La macro "MesTimers" est un petit peu modifié. Puis dans la macro FTI, il y a aussi quelque lignes pour mesurer le temps et ils ont un numéro croissant à partir de 21. Un petit peu bizarre, je sais, cet outil, je l'ai écrit ce matin sans savoir ce que j'avais à mesurer. Faites le même truc que ce matin et maintenant à la fin de msgbox final il y aura 3 nouveau temps intermédiares et je suppose que le premier sera le plus grand. La plage où vous ajustez les cellules, y-a-t-il des cellules avec de formules dedans ? Vous pouvez me joindre une sorte de copie (sans valeurs sensibles) ...