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:
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 !
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 !