Lenteur programme VBA, besoin de modification de code

Le 30/10/2019 à 11:09

Bonjour à tous,

Je suis nouveau sur le forum.

J'ai quelques questions concernant un code que j'ai développé en VBA qui me pose quelques soucis liés à la lenteur d'exécution

Dans le cadre d'un travail. J'essaye d'automatiser le remplissage de quelques feuilles Excel.

Ce fichier reprend à partir d'une feuille de données brutes quelques données. effectue quelques calculs et renvoi des synthèses et autres.

Mon code est est le suivant :

Sub Archiver()

    'Selection feuille ruptures pour remise à 0
    Sheets("Ruptures").Select
    Rows("6:6").Select 
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Delete Shift:=xlUp

    'Selection feuille pre ruptures pour remise à 0
    Sheets("Pré-Ruptures").Activate
    Rows("6:6").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Delete Shift:=xlUp

    'Selection feuille extraction pour remise à 0
    Sheets("Extraction").Activate
    Columns("A:O").Select
    Selection.ClearContents
    Rows("3:3").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Delete Shift:=xlUp

    'Selection feuille data pour copier les données utiles
    Sheets("Data").Activate
    Range("D:D,N:N,P:P,Y:Y,Z:Z,AB:AB,AC:AC,AD:AD,AE:AE,AG:AG,AL:AL,AX:AX,AY:AY,AZ:AZ,BA:BA").Select
    Selection.Copy Destination:=Sheets("Extraction").Range("A1")

    'Etendre la formule dans la feuille extraction
    Sheets("Extraction").Activate
    Range("P2:R2").Select
    Application.CutCopyMode = False
    Selection.AutoFill Destination:=Range("P2:R" & Range("R2").End(xlDown).Row)

    'Filtrer les ruptures et copier et coller les données
    Columns("F:F").Select
    Selection.AutoFilter
    ActiveSheet.Range("$F$1:F" & Range("R2").End(xlDown).Row).AutoFilter Field:=1, Criteria1:="S"
    Range("B:D,O:O").Select
    Selection.Copy
    Sheets("Ruptures").Range("Tab_Ruptures[Référence]").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

    Range("L:L").Select
    Selection.Copy
    Sheets("Ruptures").Range("Tab_Ruptures[Qté. en ruptures]").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

    Sheets("Ruptures").Activate
    Rows("5:5").Select
    Selection.Delete

    'trier les ruptures
    ActiveWorkbook.Worksheets("Ruptures").ListObjects("Tab_Ruptures").Sort. _
        SortFields.Clear
    ActiveWorkbook.Worksheets("Ruptures").ListObjects("Tab_Ruptures").Sort. _
        SortFields.Add2 Key:=Range("Tab_Ruptures[Ruptures]"), SortOn:= _
        xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("Ruptures").ListObjects("Tab_Ruptures").Sort. _
        SortFields.Add2 Key:=Range("Tab_Ruptures[Code gestionnaire]"), SortOn:= _
        xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Ruptures").ListObjects("Tab_Ruptures").Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

    'Filtrer les pré-ruptures et copier les données
    Sheets("Extraction").Activate
    Columns("F:F").Select
    Selection.AutoFilter
    ActiveSheet.Range("$F$1:F" & Range("R2").End(xlDown).Row).AutoFilter Field:=1, Criteria1:="P"
    Range("B:D,L:L").Select
    Selection.Copy
    Sheets("Pré-Ruptures").Range("Tab_PréRuptures[Référence]").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

    Range("O:O").Select
    Selection.Copy
    Sheets("Pré-Ruptures").Range("Tab_PréRuptures[Nbre de pré-ruptures]").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

    Range("E:E,M:M").Select
    Selection.Copy
    Sheets("Pré-Ruptures").Range("Tab_PréRuptures[Date de pré-rupture]").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

    'coller la liste des pré-ruptures
    Sheets("Pré-Ruptures").Activate
    Rows("5:5").Select
    Selection.Delete

    'trier les pré-ruptures
    ActiveWorkbook.Worksheets("Pré-Ruptures").ListObjects("Tab_PréRuptures").Sort. _
        SortFields.Clear
    ActiveWorkbook.Worksheets("Pré-Ruptures").ListObjects("Tab_PréRuptures").Sort. _
        SortFields.Add2 Key:=Range("Tab_PréRuptures[Nbre de pré-ruptures]"), SortOn _
        :=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("Pré-Ruptures").ListObjects("Tab_PréRuptures").Sort. _
        SortFields.Add2 Key:=Range("Tab_PréRuptures[Date de pré-rupture]"), SortOn _
        :=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortTextAsNumbers
    ActiveWorkbook.Worksheets("Pré-Ruptures").ListObjects("Tab_PréRuptures").Sort. _
        SortFields.Add2 Key:=Range("Tab_PréRuptures[Référence]"), SortOn:= _
        xlSortOnValues, Order:=xlAscending, DataOption:=xlSortTextAsNumbers
    With ActiveWorkbook.Worksheets("Pré-Ruptures").ListObjects("Tab_PréRuptures"). _
        Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

    'Copier coller les ruptures du jour sur fichier RCA
    Sheets("Ruptures").Activate
    Range("B5:G5").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy

    Sheets("RCA").Activate
    Range("B3").End(xlDown).Offset(1, 0).Select
    Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False

End Sub

J'aimerai bien savoir comment faire pour alléger le traitement

Merci

Le 30/10/2019 à 11:23

Le fonctionnement est le suivant :

1 - je supprime les données de la veille sur les feuilles "Ruptures" et "Pre-ruptures"

(le soucis peut être est que je supprime toutes les lignes à partir de la ligne 6)

2 - je récupère les données dans la feuille "data" qui me sont utiles dans mon calcul

3 - je colle les données copiées dans la feuille "extraction"

4 - sur la feuille "extraction" je déroule le calcul de quelques formules que j'ai sur la 2ème ligne

5 - j'applique des filtres sur la feuille "extraction"

6 - je copie les données filtrées en 2 temps sur les feuilles "ruptures" et "pré-ruptures"

7 - j'applique des tris sur les feuilles "ruptures" et "pré-ruptures"

8 - je copie les ruptures du jour sur la feuille "RCA" (j'additionne les ruptures du jour à veux de la veille)

Merci

Le 30/10/2019 à 12:44

Bonjour,

Le souci est que ce n'est pas un code développé mais un code enregistré.

Ce type de code ne doit servir au développeur que comme base de départ, mais pour l'essentiel 90% (parfois plus !) il est parfaitement inutile !

Il ne me semble pas possible d'optimiser ce code sans avoir le classeur ou à tout le moins un classeur quasiment identique à l'original. (au moins pour les feuilles concernées)

A+

Le 30/10/2019 à 13:01

Merci pour ta réponse et ton temps,

à vrai dire je regardais comment faire sur internet et j'enregsitrais des bouts de macros que j'adabtais pour mon besoin.

donc si je reprend les mêmes feuilles, que je recopie le code sur une nouvelle feuille je ne devrai pas avoir ce problème de lenteur

Le 30/10/2019 à 13:43

Une grosse source de ralentissement pour une macro, même si enregistrée, tu as le refresh de ton écran. Ensuite il faut retirer un maximum de .select et ligne d'après .selection. Juste avec ça tu vas pouvoir améliorer les choses

Par exemple tu transforme ça :

'Selection feuille pre ruptures pour remise à 0
    Sheets("Pré-Ruptures").Activate
    Rows("6:6").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Delete Shift:=xlUp

en ça :

Sheets("Pré-Ruptures").Range(Rows(6), Rows(65536)).Delete Shift:=xlUp
Rechercher des sujets similaires à "lenteur programme vba besoin modification code"