Améliorer une macro pour rendre son exécution plus rapide

Le 14/11/2013 à 09:08

Bonjour,

J'ai créé une macro dont certaines parties du code ont été écrites par enregistrement de mes actions sur le fichier. J'ai ensuite remanié le code pour supprimer certaines lignes que j'ai pu identifier comme étant superflues, mais ma macro reste assez lente.

Voici le code:

Sub MiseàJour()
'

Dim WbsK As Workbook
    Dim Cel As Range
'
'Extraction 
'
'Copier-Coller Liste Arrêts
'
    Sheets("Niveau2").Columns("A:D").ClearContents
    Sheets("Niveau3").Columns("A:D").ClearContents
    '
    'Ouvrir le fichier des arrêts
    Set Wbks = Workbooks.Open(Filename:="T:\Extractions\ListeArrets.xlsx")
    '
    'Réactiver ce classeur
    ThisWorkbook.Activate
    '
    'Copier les colonnes du classeur source et les coller dans ce classeur
    Wbks.Sheets("Résultats").Columns("F:I").Copy
    Windows("Arrêts de ligne.xlsm").Activate
    Sheets("Niveau2").Select
    Range("A1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("A1").Select
    Sheets("Niveau3").Select
    Range("A1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("A1").Select
'
'
'
'
'
''
'
Sheets("TCD").Select
'
'Suppression des filtres
    'Filtre temps total (valeurs nulles)
    ActiveSheet.PivotTables("TCD niveau3").PivotFields("Temps total") _
        .CurrentPage = "(All)"
    With ActiveSheet.PivotTables("TCD niveau3").PivotFields( _
        "Temps total")
        .PivotItems("0").Visible = True
    End With
    'Filtre 3 premières causes
    ActiveSheet.PivotTables("TCD niveau3").PivotFields("Niveau 2"). _
        ClearValueFilters
'
'Actualiser les données du tableau
    ActiveSheet.PivotTables("TCD niveau3").PivotCache.Refresh
'
'Filtrer les 3 premières causes
    ActiveSheet.PivotTables("TCD niveau3").PivotFields("Niveau 2"). _
        PivotFilters.Add Type:=xlTopCount, DataField:=ActiveSheet.PivotTables( _
        "TCD niveau3").PivotFields("Somme de Pourcentage du temps"), _
        Value1:=3
'
'Filtrer les valeurs nulles
    ActiveSheet.PivotTables("TCD niveau3").PivotFields("Temps total") _
        .CurrentPage = "(All)"
    With ActiveSheet.PivotTables("TCD niveau3").PivotFields( _
        "Temps total")
        .PivotItems("0").Visible = False
    End With
'
'Supprimer le filtre "cellules vides" sur le feuillet du graphique
    Sheets("Graphique niveau3").Select
    ActiveSheet.Range("$C$1:$C$52").AutoFilter Field:=1
'
'Supprimer le contenu du graphique
    Columns("A:B").Select
    Selection.ClearContents
    With Selection.Interior
        .Pattern = xlNone
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
'
'Copie du TCD
    Sheets("TCD").Select
    Columns("B:C").Select
    Selection.Copy
    Range("A1").Select
'
'Coller valeurs et mise en forme
    Sheets("Graphique niveau3").Select
    Range("B1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
'
'Masquer les cellules vides
    ActiveSheet.Range("$C$1:$C$52").AutoFilter Field:=1, Criteria1:="<>"
'
'Couleurs du graphique
    Dim Sér As Series, PlgX As Range, Zon As Range, Cels As Range, I As Long
    Set Sér = ActiveSheet.ChartObjects(1).Chart.SeriesCollection(1)
    Set PlgX = Application.Range(Split(Sér.Formula, ",")(1))
    For Each Zon In PlgX.SpecialCells(xlCellTypeVisible)
        For Each Cels In Zon
            I = I + 1: Sér.Points(I).Interior.Color = Cels.Interior.Color
            Next Cels, Zon
Range("A1").Select
'
'Fin SPI et date page d'accueil
'
Sheets("Accueil").Select
Windows("ListeArrets.xlsx").Activate
Sheets("En-Tête").Range("A2:C4").Copy
    Windows("Arrêts de ligne.xlsm").Activate
    Sheets("Accueil").Select
    Range("B2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Windows("ListeArrets.xlsx").Activate
    ActiveWindow.Close
'
'Extraction TRH V2
'
'
    'Préparation du fichier pour accueillir les nouvelles données
    Sheets("TRH").Select
    Cells.Select
    Selection.EntireRow.Hidden = False
    Range("A1:W17").Select
    Selection.ClearContents
    '
    'Copier les nouvelles données de l'extraction
    Workbooks.Open Filename:= _
        "T:\Extractions\Indicateur_HFE.xls"
    Range("E9:AB25").Select
    Selection.Copy
    '
    'Copier les valeurs
    Windows("Arrêts de ligne.xlsm").Activate
    Range("B1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    '
    'Préparer le tableau pour le diagramme
    Range("B28:I34").Select
    Selection.Copy
    Range("B36").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    '
    'Masquer les lignes inutiles
    Rows("1:17").Select
    Selection.EntireRow.Hidden = True
    Rows("28:35").Select
    Selection.EntireRow.Hidden = True
    '
    'Trier les données par TRH décroissant
    Range("B36:I42").Select
    ActiveWorkbook.Worksheets("TRH").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("TRH").Sort.SortFields.Add Key:=Range("G42:G48"), _
        SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("TRH").Sort
        .SetRange Range("B36:I42")
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    '
    'Fin
    Range("A18").Select
    Sheets("Accueil").Select
    Range("A1").Select
    Windows("Indicateur_HFE.xls").Activate
    ActiveWindow.Close
End Sub

Quelqu'un pourrait-il m'aider à épurer le langage afin de rendre la macro plus rapide à l'exécution ??

Merci d'avance pour votre aide !

Le 14/11/2013 à 13:37

Bonjour

Pas facile de te donner tout sans voir le fichier

Le début de ta macro pourrait être ceci :

Sub MiseàJour()
Dim WbsK As Workbook
Dim Cel As Range
'Extraction
'
'Copier-Coller Liste Arrêts
Sheets("Niveau2").Columns("A:D").ClearContents
Sheets("Niveau3").Columns("A:D").ClearContents
'Ouvrir le fichier des arrêts
Set Wbks = Workbooks.Open(Filename:="T:\Extractions\ListeArrets.xlsx")
   'Réactiver ce classeur
'ThisWorkbook.Activate
'Copier les colonnes du classeur source et les coller dans ce classeur
Wbks.Sheets("Résultats").Columns("F:I").Copy
With Workbooks("Arrêts de ligne.xlsm")
    .Sheets("Niveau2").Range("A1").PasteSpecial Paste:=xlPasteValues
    .Sheets("Niveau3").Range("A1").PasteSpecial Paste:=xlPasteValues
End With
Sheets("TCD").select
...

A te relire pour aller plus loin et surtout comprendre le pourquoi de certaines instructions

Rechercher des sujets similaires à "ameliorer macro rendre execution rapide"