Accélérer une macro VBA en épurant le langage

jacky128

XLDnaute Nouveau
Bonjour,

J'ai créé une macro, et certaines parties du code de cette macro ont été écrites par enregistrement de mes actions sur le fichier. Cependant, ma macro se révèle être assez lente, bien que j'ai déjà supprimé les défilements d'écran et certains Select..

Voici le code:

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 UP1.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
'
'
    '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

Pourriez-vous m'indiquer comment modifier le code afin que la macro soit moins lourde et plus rapide s'il vous plait ??
Remarque: il faut que la macro reste compatible avec Excel 2003 et 2007.

Merci d'avance pour votre aide !
 

Staple1600

XLDnaute Barbatruc
Re : Accélérer une macro VBA en épurant le langage

Bonjour à tous


Il y a encore beaucoup de Select supprimables
Exemple
Code:
'Supprimer le contenu du graphique
    Columns("A:B").Clear
'
'Copie du TCD
    Sheets("TCD").Columns("B:C").Copy
Je te laisse continue la cure d'amaigrissement ;)
 

Discussions similaires

Réponses
2
Affichages
80

Statistiques des forums

Discussions
311 733
Messages
2 082 019
Membres
101 872
dernier inscrit
Colin T