Accélérer une macro

C

clairew

XLDnaute Nouveau
Bonjour,

Je pars de zéro en ce qui concerne la programmation VBA. J'ai tout appris par vous, un grand merci :)

Aujourd'hui, premier post puisque je ne trouve plus de solution. J'ai un code qui marche parfaitement, mais dont le temps d'exécution est interminable. C'est un outil dit opérationnel, il doit être le plus réactif possible!

Je précise que je ne sais pas encore bien utiliser le forum, donc je m'en excuse d'avance! Merci!


VB: 
Sub MàJ_Liste()

' Travail caché
Application.ScreenUpdating = False
' Délclaration de variables
Dim Lig As Integer
' Mise à jour des formules
' Sélection de l'onglet Liste
Sheets("Liste").Select
' Déproéger l'onglet
ActiveSheet.Unprotect ("corps")
' Démasquer les colonnes N à U
Columns("O:W").Select
Selection.EntireColumn.Hidden = False
' Suppression des formules
Range("P3:W65536").Select
Selection.ClearContents
' Sélection de la ligne maximale
Lig = Range("C" & Rows.Count).End(xlUp).Row
' Copier les formules jusqu'à la fin du fichier
Range("P2:W2").Select

Selection.AutoFill Destination:=Range(Cells(2, 16), Cells(Lig, 23))
' Masquer les colonnes de N ) U
Columns("P:W").Select
Selection.EntireColumn.Hidden = True
' Protéger l'onglet
ActiveSheet.Protect ("corps")
' Mise à jour du tableau croisé dynamique
' Sélection de l'onglet OLV étranger
Sheets("OLV étranger").Select
' Mise à jour du tableau
ActiveSheet.PivotTables("Tableau croisé dynamique1").PivotCache.Refresh
ActiveSheet.PivotTables("Tableau croisé dynamique1").PivotFields("Pays"). _
CurrentPage = "(All)"
With ActiveSheet.PivotTables("Tableau croisé dynamique1").PivotFields("Pays")
.PivotItems("FRA").Visible = False
.PivotItems("(blank)").Visible = False
End With
'
'
'
'
' Mise à jour de l'onglet Affretement
' Déclaration de variables
Dim Tdonnées(400, 5) As Variant
Dim Lig1 As Integer
Dim Lig2 As Integer
Dim i As Integer
Dim j As Integer

' Lig maximale OLV
Lig1 = Range("A" & Rows.Count).End(xlUp).Row
' Lig maximale OTR
Lig2 = Range("E" & Rows.Count).End(xlUp).Row
' Sélection des données
j = 0
For i = 0 To (Lig1 - 6)
Tdonnées(i, 0) = Cells(6 + i, 1)
Tdonnées(i, 1) = Cells(6 + i, 2)
j = j + 1
Next
For i = o To (Lig2 - 6)
Tdonnées(i + j, 0) = Cells(6 + i, 5)
Tdonnées(i + j, 1) = Cells(6 + i, 6)
Next
' Copier les données
' Sélection de l'onglet Affretement
Sheets("Affretement").Select

' Suppression des données
Range("A18:B65536,C19:L65536").Select
Selection.ClearContents

' Suppression de la mise en forme
ActiveSheet.Rows("19:100").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
Selection.Borders(xlEdgeTop).LineStyle = xlNone
Selection.Borders(xlEdgeBottom).LineStyle = xlNone
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone


' Copier les données
For i = 0 To (Lig1 - 6 + Lig2 - 6 + 1)
Cells(18 + i, 1) = Tdonnées(i, 0)
Cells(18 + i, 2) = Tdonnées(i, 1)
Next
' Coller les formules
' Sélection de la ligne maximale
Lig = Range("A" & Rows.Count).End(xlUp).Row
' Copier les formules jusqu'à la fin du fichier
Range("C18:L18").Select

Selection.AutoFill Destination:=Range(Cells(18, 3), Cells(Lig, 12))

' Mise en page
Range(Cells(18, 1), Cells(Lig, 12)).Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlDouble
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThick
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlDouble
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThick
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlDouble
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThick
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
' Mise en forme pour l'impression
Range(Cells(4, 1), Cells(Lig, 12)).Select
ActiveSheet.PageSetup.PrintArea = "$A$4:$L$" & Lig

Application.ScreenUpdating = True
End Sub
 
Dernière édition:
Trier par date Trier par votes
C

clairew

XLDnaute Nouveau
Re : Accélérer une macro

Je réalise combien ce code est long... la partie la plus problématique au point de vue temps d'exécution est celle-ci. Merci par avance,

VB: 
 Mise à jour de l'onglet Affretement
' Déclaration de variables
Dim Tdonnées(400, 5) As Variant
Dim Lig1 As Integer
Dim Lig2 As Integer
Dim i As Integer
Dim j As Integer

' Lig maximale OLV
Lig1 = Range("A" & Rows.Count).End(xlUp).Row
' Lig maximale OTR
Lig2 = Range("E" & Rows.Count).End(xlUp).Row
' Sélection des données
j = 0
For i = 0 To (Lig1 - 6)
Tdonnées(i, 0) = Cells(6 + i, 1)
Tdonnées(i, 1) = Cells(6 + i, 2)
j = j + 1
Next
For i = o To (Lig2 - 6)
Tdonnées(i + j, 0) = Cells(6 + i, 5)
Tdonnées(i + j, 1) = Cells(6 + i, 6)
Next
' Copier les données
' Sélection de l'onglet Affretement
Sheets("Affretement").Select

' Suppression des données
Range("A18:B65536,C19:L65536").Select
Selection.ClearContents

' Suppression de la mise en forme
ActiveSheet.Rows("19:100").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
Selection.Borders(xlEdgeTop).LineStyle = xlNone
Selection.Borders(xlEdgeBottom).LineStyle = xlNone
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone


' Copier les données
For i = 0 To (Lig1 - 6 + Lig2 - 6 + 1)
Cells(18 + i, 1) = Tdonnées(i, 0)
Cells(18 + i, 2) = Tdonnées(i, 1)
Next
' Coller les formules
' Sélection de la ligne maximale
Lig = Range("A" & Rows.Count).End(xlUp).Row
' Copier les formules jusqu'à la fin du fichier
Range("C18:L18").Select

Selection.AutoFill Destination:=Range(Cells(18, 3), Cells(Lig, 12))
 
Dernière édition:
Vote positif 0 Vote négatif
mromain

mromain

XLDnaute Barbatruc
Re : Accélérer une macro

Bonjour clairew et bienvenue sur le forum,

Déjà, si tu comptes accélérer le code, il faut essayer de se passer des Select.
Par exemple, dans cette partie de ton code :
VB: 
' Sélection de l'onglet Affretement
Sheets("Affretement").Select
' Suppression des données
Range("A18:B65536,C19:L65536").Select
Selection.ClearContents
Tu peux ici éviter les Select avec ce code
VB: 
ThisWorkbook.Sheets("Affretement").Range("A18:B65536,C19:L65536").ClearContents
Il est vrai qu'écrire sans arrêt ThisWorkbook.Sheets("MaFeuille") est vite contraignant, tu peux alors utiliser une variable Worksheet afin d'avoir l'écriture automatique, ainsi que l'instruction Ce lien n'existe plus pour alléger le code :
VB: 
Dim shAffr As Worksheet
    Set shAffr = ThisWorkbook.Sheets("Affretement")
    
    With shAffr
        ' Lig maximale OLV / OTR
        Lig1 = .Range("A" & .Rows.Count).End(xlUp).Row
        Lig2 = .Range("E" & .Rows.Count).End(xlUp).Row
        
        '...
        
        ' Suppression des données / mise en forme
        .Range("A18:B65536,C19:L65536").ClearContents
        With .Range("19:100")
            .Borders.LineStyle = xlNone
            .Borders(xlDiagonalDown).LineStyle = xlNone
            .Borders(xlDiagonalUp).LineStyle = xlNone
        End With
    End With
Sinon, pour vraiment améliorer le code, il nous faudrait un petit fichier avec des données et des explications sur le résultat attendu.

PS: Lorsque tu postes du code, pense à utiliser la balise highlight : [noparse]
VB: 
ton code VBA
[/noparse].

A+
 
Vote positif 0 Vote négatif
C

clairew

XLDnaute Nouveau
Re : Accélérer une macro

Déjà un grand merci à toi! Je regarde ce que je peux apporter comme améliorations sur cette base avant de vous renvoyer un code.

Je vais également essayer de créer un fichier plus light et surtout sans infos confidentielles!!
 
Vote positif 0 Vote négatif

Discussions similaires

F
  • Résolu(e)
XL 2021 Créer Macro permettant d'indexer des nouveaux clients ? [Résolu]
4 5 6
Réponses
82
Affichages
2 K
fanou06
F
R
  • Question
XL 2016 Rendre plus lisible un code VBA
2
Réponses
23
Affichages
1 K
TooFatBoy
TooFatBoy
H
  • Question
XL 2016 Mettre des titres avec une mise en forme spécifique
Réponses
1
Affichages
316
vgendron
vgendron
K
  • Question
XL 2019 Organiser le code VBA
Réponses
9
Affichages
632
Kevin38
K
L
  • Question
Microsoft 365 Changement de couleurs de cellules dans plusieurs feuilles suite à une modification
Réponses
4
Affichages
408
lolo_excelbeginner
L
F
  • Question
Microsoft 365 Poursuivre ou pas la macro
Réponses
2
Affichages
250
Francky79
F
ZAKAO
  • Résolu(e)
XL 2013 Ecriture de code condensé
Réponses
9
Affichages
426
ZAKAO
ZAKAO
Syracoti
  • Résolu(e)
XL 2016 Changer de feuille dans une macro
2
Réponses
28
Affichages
3 K
Staple1600
Staple1600
B
  • Question
XL 2013 Comment trier les nom des feuilles et fusionner leur tableaux dans une une autre feuille ?
Réponses
10
Affichages
303
Compte Supprimé 979
C
dindin
  • Question
XL 2016 simplifier une macro enregistrée
Réponses
8
Affichages
589
dindin
dindin

Membres actuellement en ligne

5 membres et 39 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 677
Messages
2 090 821
Membres
104 677
dernier inscrit
soufiane12