Accélération d'une macro

Le 17/02/2015 à 13:07

Bonjour tout le monde,

Je suis novice en macro, à force de tuto et de coup de pouce du forum ma plus grosse macro est enfin sur pied. Je pense que pour les experts la macro doit très certainement piquer aux yeux. J'en suis désolé, on est surement tous passé par cette étape :p

Ma macro est particulièrement longue car c'est une série de tâche, j'ai segmenté le code par étape et donc par code succeptible d'être similaire mais au final la vraie macro c'est tous les codes à la suite.

J'ai déjà cherché un peu comme accélérer une macro, il y a le Application.ScreenUpdating qui fait déjà gagné pas mal de temps et qui n'a pas de contrainte pour être appliqué. Pour les autres j'ai peur que les contraintes me fasse sauter ma macro qui est très fragile, bardé de rustine. Actuellement elle mets 47s à s'exécuter !

Je sais qu'il y a des écritures qui peuvent être remplacé/rectifier pour demander moins de temps de travail à la macro mais je ne sais pas trop lequel et surtout qu'elle est la meilleure écriture pour remplacer.

Est ce qu'on âme charitable à :

1/ une astuce globale pour accélérer le tout ( style Application.ScreenUpdating )

2/ m'indiquer quels types de lignes de code est vraiment mal écrite et ralentie l'exécution avec un petit exemple de bonne écriture pour que je puisse le corriger pour le reste de la macro (car il y a pas mal de code similaire au final)

Merci beaucoup à l'ensemble des gens du forum qui m'en permis d'avancer dans la maîtrise (si faible qu'elle soit pour le moment ^^) du macro et qui m'a permis déjà un gain phénoménal du temps !!

Application.ScreenUpdating = False 'accélérer macro début script'

'Copier les données angles et tensions de Sujet RI et RE dans la feuille All mvt'
'Pour bras gauche d'abord RE puis ensuite RI, pour le bras droit faudra changer'

Sheets("Sujet RE").Select
    Range("B24:C24").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Sheets("All mvt").Select                'copier dans All mvt'
    ActiveWindow.SmallScroll Down:=-141
    Range("B24").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

    'supprimer la dernière des 2 colonnes car le début de RE c'est la même valeur que la dernière de RI'
    LaDerniere = Range("B500").End(xlUp).Offset(0, 0).Select
    Selection.ClearContents
    LaDerniere = Range("C500").End(xlUp).Offset(0, 0).Select
    Selection.ClearContents

Sheets("Sujet RI").Select
    Range("B24:C24").Select
    Range(Selection, Selection.End(xlDown)).Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("All mvt").Select                'copier dans All mvt'
    Range("B65536").End(xlUp).Offset(1, 0).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

'Macro pour créer d'autres colonnes de données pour faire les graphiques pour la RI et la RE'
'permet de créer les colonnes pour moyenner après'

Sheets("Sujet RI").Select       'travail pour RI donc avec recherche de max de C pour le bras gauche'
    Dim Xyz As Long
    Dim Ijk As Range

  Application.ScreenUpdating = False
  Xyz = Range("B" & Rows.Count).End(xlUp).Row

  Set Ijk = Range("C24:C" & Xyz).Find(what:=Application.min(Range("C24:C" & Xyz)), LookIn:=xlValues, lookat:=xlWhole)
  If Not Ijk Is Nothing Then
    Range("B24:C" & Ijk.Row + 3).Copy Range("P24")
    Range("B" & Ijk.Row - 2 & ":C" & Xyz).Copy Range("S24")
  End If

Sheets("Sujet RE").Select       'travail pour RE donc avec recherche de min de C pour le bras gauche'
    Dim Lmn As Long
    Dim Opq As Range

  Application.ScreenUpdating = False
  Lmn = Range("B" & Rows.Count).End(xlUp).Row

  Set Opq = Range("C24:C" & Lmn).Find(what:=Application.Max(Range("C24:C" & Lmn)), LookIn:=xlValues, lookat:=xlWhole)
  If Not Opq Is Nothing Then
    Range("B24:C" & Opq.Row + 3).Copy Range("P24")
    Range("B" & Opq.Row - 2 & ":C" & Lmn).Copy Range("S24")
  End If

    'Copie les données qu'il faut pour les 4 graphiques de la feuille All mvt'

    Sheets("Sujet RI").Select           'Aller RI'
    Range("P25:Q25").Select             'Attention commence à 25 car celle de 24 = la dernière de Retour RE INVERSE pour bras droit !'
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Sheets("All mvt").Select
    Range("Q24").Select
    ActiveSheet.Paste

    Sheets("Sujet RI").Select           'Retour RI'
    Range("S24:T24").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Sheets("All mvt").Select
    Range("T24").Select
    ActiveSheet.Paste

    Sheets("Sujet RE").Select           'Aller RE'
    Range("P24:Q24").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Sheets("All mvt").Select
    Range("W24").Select
    ActiveSheet.Paste

    Sheets("Sujet RE").Select           'Retour RE'
    Range("S24:T24").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Sheets("All mvt").Select
    Range("AC24").Select
    ActiveSheet.Paste

    'Rajoute 5 données en fin de colonne Retour RE pour que le moyennage soit bon graphiquement pr All mvt!'
    Sheets("All mvt").Select
    Range("Q25:R30").Select
    Selection.Copy
    Range("AC65536").End(xlUp).Offset(1, 0).Select 'se positionner sur la dernière cellule vide de la colonne'
    ActiveSheet.Paste
'MFC pour angle neutre et min max tension pour les 3 feuilles'

Sheets("Sujet RI").Select       'travail Sujet RI'

    Range("B24").Select         'MFC pour les angles'
    Range(Selection, Selection.End(xlDown)).Select

    Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlBetween, _
        Formula1:="=-10", Formula2:="=10"
    Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
    With Selection.FormatConditions(1).Interior
        .PatternColorIndex = xlAutomatic
        .Color = 15773696
        .TintAndShade = 0
    End With

    Range("C24").Select         'MFC pour les tensions MIN'
    Range(Selection, Selection.End(xlDown)).Select
    Selection.FormatConditions.AddTop10
    Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
    With Selection.FormatConditions(1)
        .TopBottom = xlTop10Bottom
        .Rank = 1
        .Percent = False
    End With
    With Selection.FormatConditions(1).Interior
        .PatternColorIndex = xlAutomatic
        .Color = 255
        .TintAndShade = 0
    End With
    Selection.FormatConditions(1).StopIfTrue = False

Sheets("Sujet RE").Select       'travail Sujet RE'

    Range("B24").Select         'MFC pour les angles'
    Range(Selection, Selection.End(xlDown)).Select

    Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlBetween, _
        Formula1:="=-10", Formula2:="=10"
    Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
    With Selection.FormatConditions(1).Interior
        .PatternColorIndex = xlAutomatic
        .Color = 15773696
        .TintAndShade = 0
    End With

    Range("C24").Select 'MFC pour les tensions MAX'
    Range(Selection, Selection.End(xlDown)).Select

    Selection.FormatConditions.AddTop10
    Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
    With Selection.FormatConditions(1)
        .TopBottom = xlTop10Top
        .Rank = 1
        .Percent = False
    End With
    With Selection.FormatConditions(1).Interior
        .PatternColorIndex = xlAutomatic
        .Color = 5296274
        .TintAndShade = 0
    End With

Sheets("All mvt").Select       'travail All mvt'
    Range("B24").Select         'MFC pour les angles'
    Range(Selection, Selection.End(xlDown)).Select

    Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlBetween, _
        Formula1:="=-10", Formula2:="=10"
    Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
    With Selection.FormatConditions(1).Interior
        .PatternColorIndex = xlAutomatic
        .Color = 15773696
        .TintAndShade = 0
    End With

    Range("C24").Select         'MFC pour les tensions MIN'
    Range(Selection, Selection.End(xlDown)).Select
    Selection.FormatConditions.AddTop10
    Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
    With Selection.FormatConditions(1)
        .TopBottom = xlTop10Bottom
        .Rank = 1
        .Percent = False
    End With
    With Selection.FormatConditions(1).Interior
        .PatternColorIndex = xlAutomatic
        .Color = 255
        .TintAndShade = 0
    End With
    Selection.FormatConditions(1).StopIfTrue = False

    Range("C24").Select 'MFC pour les tensions MAX'
    Range(Selection, Selection.End(xlDown)).Select

    Selection.FormatConditions.AddTop10
    Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
    With Selection.FormatConditions(1)
        .TopBottom = xlTop10Top
        .Rank = 1
        .Percent = False
    End With
    With Selection.FormatConditions(1).Interior
        .PatternColorIndex = xlAutomatic
        .Color = 5296274
        .TintAndShade = 0
    End With
' Recherche tension max-min et l'angle associé pour Sujet RI et Sujet RE '

Sheets("Sujet RI").Select 'on travaille ici RI' ' Ici on va chercher la plus grande valeur d'une colonne

    j = 3           'fixer le numéro de colonne voulu
    i = 24          'ligne de début de recherche
    Value = 99999   'variable qui aura la plus grande valeur (si ça va dans les négatifs, alors la fixer à -99999 par exemple)
    Value2 = 0      'la voisine à gauche'
    While Not IsEmpty(Cells(i, j))
        If Cells(i, j) < Value Then     'changer le signe si on cherche la plus petite
            Value = Cells(i, j)
            Value2 = Cells(i, j - 1)
        End If
        i = i + 1
    Wend

    'on les copie là où on veut (changer N34 et N35 en ce que l'on veut)
    Range("N24").Value = Value
    Range("M24").Value = Value2

Sheets("Sujet RE").Select   'on travaille ici RE'

    j = 3           'fixer le numéro de colonne voulu
    i = 24          'ligne de début de recherche
    Value = -99999  'variable qui aura la plus grande valeur (si ça va dans les négatifs, alors la fixer à -99999 par exemple)
    Value2 = 0      'la voisine à gauche
    While Not IsEmpty(Cells(i, j))
        If Cells(i, j) > Value Then     'changer le signe si on cherche la plus petite
            Value = Cells(i, j)
            Value2 = Cells(i, j - 1)
        End If
        i = i + 1
    Wend

    'on les copie là où on veut (changer N34 et N35 en ce que l'on veut)
    Range("N24").Value = Value
    Range("M24").Value = Value2
' Automatisation Copier Coller Hystérésis RI et RE '

Sheets("Sujet RI").Select       'travail pour RI donc avec recherche de max de C pour le bras gauche'
    Dim Nblg As Long
    Dim Cel As Range

  Application.ScreenUpdating = False
  Nblg = Range("B" & Rows.Count).End(xlUp).Row

  Set Cel = Range("C24:C" & Nblg).Find(what:=Application.min(Range("C24:C" & Nblg)), LookIn:=xlValues, lookat:=xlWhole)
  If Not Cel Is Nothing Then
    Range("B24:C" & Cel.Row + 0).Copy Destination:=Sheets("Hysteresis RI").Range("A2")
    Range("B" & Cel.Row & ":C" & Nblg).Copy Destination:=Sheets("Hysteresis RI").Range("I2")
  End If

    ' Permet de supprimer les mises en forme conditionnelles et de décaler d'une donnée le retour car le max de tension et aussi dans le retour à la base de copier coller'
    Sheets("Hysteresis RI").Select
    Range("A2:B2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.FormatConditions.Delete
    Range("I2:J2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.FormatConditions.Delete
    Range("I3:J3").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Range("I2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False

    ' On peut pas faire de coller spécial avec un couper'
    ' Du coup last valeur en double alors on supprime la dernière valeur'
    LaDerniere = Range("I500").End(xlUp).Offset(0, 0).Select
    Selection.ClearContents
    LaDerniere = Range("J500").End(xlUp).Offset(0, 0).Select
    Selection.ClearContents

    ' Ajustement de la dernière valeur pour l'hystérésis RI pour avoir une aires exacte '
    ' Etape 1 supprimer tous les 0 de la colonne dont le numéro est dans le j= et de la ligne i='
    Sheets("Hysteresis RI").Select
    For i = 3 To 200              'de la ligne à la ligne
    For j = 7 To 7                'de la colonne à la colonne'
    If Cells(i, j) <= 0 Then
    Cells(i, j).ClearContents
    End If
    Next j
    Next i

    For i = 3 To 200             'de la ligne à la ligne
    For j = 15 To 15             'de la colonne à la colonne'
    If Cells(i, j) <= 0 Then
    Cells(i, j).ClearContents
    End If
    Next j
    Next i

    ' Une fois les 0 enlevé on dit de supprimer les dernière valeur'
    LaDerniere = Range("G500").End(xlUp).Offset(0, 0).Select
    Selection.ClearContents
    LaDerniere = Range("O500").End(xlUp).Offset(0, 0).Select
    Selection.ClearContents

Sheets("Sujet RE").Select       'travail pour RE donc avec recherche de min de C pour le bras gauche'
    Dim Abc As Long
    Dim Def As Range

    Application.ScreenUpdating = False
    Abc = Range("B" & Rows.Count).End(xlUp).Row

    Set Def = Range("C24:C" & Abc).Find(what:=Application.Max(Range("C24:C" & Abc)), LookIn:=xlValues, lookat:=xlWhole)
    If Not Def Is Nothing Then
        Range("B24:C" & Def.Row).Copy Destination:=Sheets("Hysteresis RE").Range("A2")
        Range("B" & Def.Row & ":C" & Abc).Copy Destination:=Sheets("Hysteresis RE").Range("I2")
     End If

    ' Permet de supprimer les mises en forme conditionnelles et de décaler d'une donnée le retour car le max de tension et aussi dans le retour à la base de copier coller'
    Sheets("Hysteresis RE").Select
    Range("A2:B2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.FormatConditions.Delete
    Range("I2:J2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.FormatConditions.Delete
    Range("I3:J3").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Range("I2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False

    ' On peut pas faire de coller spécial avec un couper'
    ' Du coup last valeur en double alors on supprime la dernière valeur'
    LaDerniere = Range("I500").End(xlUp).Offset(0, 0).Select
    Selection.ClearContents
    LaDerniere = Range("J500").End(xlUp).Offset(0, 0).Select
    Selection.ClearContents

    ' Ajustement de la dernière valeur pour l'hystérésis RI pour avoir une aires exacte '
    ' Etape 1 supprimer tous les 0 de la colonne dont le numéro est dans le j= et de la ligne i='
    Sheets("Hysteresis RE").Select
    For i = 3 To 200               'de la ligne à la ligne'
    For j = 7 To 7                 'de la colonne à la colonne'
    If Cells(i, j) <= 0 Then
    Cells(i, j).ClearContents
    End If
    Next j
    Next i

    For i = 3 To 200                'de la ligne à la ligne
    For j = 15 To 15                'de la colonne à la colonne'
    If Cells(i, j) <= 0 Then
    Cells(i, j).ClearContents
    End If
    Next j
    Next i

    ' Une fois les 0 enlevé on dit de supprimer les dernière valeur'
    LaDerniere = Range("G500").End(xlUp).Offset(0, 0).Select
    Selection.ClearContents
    LaDerniere = Range("O500").End(xlUp).Offset(0, 0).Select
    Selection.ClearContents
'Macro pour créer les graphiques RI RE et All mvt'

Sheets("Sujet RI").Select                   ' ROTATION INTERNE '
    ActiveSheet.ChartObjects("Graphique 4").Activate
    ActiveWindow.SmallScroll Down:=-150
    ActiveSheet.ChartObjects("Graphique 4").Activate
    ActiveWindow.SmallScroll Down:=-45
    ActiveWindow.SmallScroll ToRight:=5
    ActiveChart.SeriesCollection.NewSeries
    ActiveChart.SeriesCollection(2).Name = "=""Aller"""
    ActiveChart.SeriesCollection(2).XValues = "='Sujet RI'!$Y$27:$Y$172"
    ActiveChart.SeriesCollection(2).Values = "='Sujet RI'!$Z$27:$Z$172"
    ActiveWindow.SmallScroll ToRight:=-11
    ActiveSheet.ChartObjects("Graphique 4").Activate
    ActiveChart.SeriesCollection(2).Select
    With Selection.Format.Line
        .Visible = msoTrue
        .ForeColor.RGB = RGB(146, 208, 80)
    End With
    ActiveChart.ChartArea.Select
    ActiveChart.SeriesCollection.NewSeries
    ActiveChart.SeriesCollection(3).Name = "=""Retour"""
    ActiveChart.SeriesCollection(3).XValues = "='Sujet RI'!$AD$27:$AD$172"
    ActiveChart.SeriesCollection(3).Values = "='Sujet RI'!$AE$27:$AE$172"
    ActiveChart.SeriesCollection(3).Select
    With Selection.Format.Line
        .Visible = msoTrue
        .ForeColor.RGB = RGB(146, 208, 80)
    End With
    With Selection.Format.Line
        .Visible = msoTrue
        .ForeColor.RGB = RGB(255, 0, 0)
        .Transparency = 0
    End With

Sheets("Sujet RE").Select                   ' ROTATION EXTERNE '
    ActiveSheet.ChartObjects("Graphique 4").Activate
    ActiveWindow.SmallScroll Down:=-150
    ActiveSheet.ChartObjects("Graphique 4").Activate
    ActiveWindow.SmallScroll Down:=-45
    ActiveWindow.SmallScroll ToRight:=5
    ActiveChart.SeriesCollection.NewSeries
    ActiveChart.SeriesCollection(2).Name = "=""Aller"""
    ActiveChart.SeriesCollection(2).XValues = "='Sujet RE'!$Y$27:$Y$172"
    ActiveChart.SeriesCollection(2).Values = "='Sujet RE'!$Z$27:$Z$172"
    ActiveWindow.SmallScroll ToRight:=-11
    ActiveSheet.ChartObjects("Graphique 4").Activate
    ActiveChart.SeriesCollection(2).Select
    With Selection.Format.Line
        .Visible = msoTrue
        .ForeColor.RGB = RGB(146, 208, 80)
    End With
    ActiveChart.ChartArea.Select
    ActiveChart.SeriesCollection.NewSeries
    ActiveChart.SeriesCollection(3).Name = "=""Retour"""
    ActiveChart.SeriesCollection(3).XValues = "='Sujet RE'!$AD$27:$AD$172"
    ActiveChart.SeriesCollection(3).Values = "='Sujet RE'!$AE$27:$AE$172"
    ActiveChart.SeriesCollection(3).Select
    With Selection.Format.Line
        .Visible = msoTrue
        .ForeColor.RGB = RGB(146, 208, 80)
    End With
    With Selection.Format.Line
        .Visible = msoTrue
        .ForeColor.RGB = RGB(255, 0, 0)
        .Transparency = 0
    End With

Sheets("All mvt").Select                ' ALL MOUVEMENT '
    ActiveSheet.ChartObjects("Graphique 4").Activate
    ActiveChart.SeriesCollection.NewSeries
    ActiveChart.SeriesCollection(3).Name = "=""Aller RI"""
    ActiveChart.SeriesCollection(3).XValues = "='All mvt'!$AH$27:$AH$300"
    ActiveChart.SeriesCollection(3).Values = "='All mvt'!$AI$27:$AI$300"
    ActiveSheet.ChartObjects("Graphique 4").Activate
    ActiveChart.SeriesCollection(3).Select
    With Selection.Format.Line
        .Visible = msoTrue
        .ForeColor.RGB = RGB(255, 0, 0)
    End With
    With Selection.Format.Line
        .Visible = msoTrue
        .ForeColor.RGB = RGB(146, 208, 80)
        .Transparency = 0
    End With
    ActiveChart.ChartArea.Select
    ActiveChart.SeriesCollection.NewSeries
    ActiveChart.SeriesCollection(4).Name = "=""Retour RI"""
    ActiveChart.SeriesCollection(4).XValues = "='All mvt'!$AM$27:$AM$300"
    ActiveChart.SeriesCollection(4).Values = "='All mvt'!$AN$27:$AN$300"
    ActiveChart.SeriesCollection(4).Select
    With Selection.Format.Line
        .Visible = msoTrue
        .ForeColor.RGB = RGB(146, 208, 80)
    End With
    With Selection.Format.Line
        .Visible = msoTrue
        .ForeColor.RGB = RGB(255, 0, 0)
        .Transparency = 0
    End With
    ActiveChart.ChartArea.Select
    ActiveChart.SeriesCollection(4).Select
    ActiveChart.ChartArea.Select
    ActiveChart.SeriesCollection.NewSeries
    ActiveChart.SeriesCollection(5).Name = "=""Aller RE"""
    ActiveChart.SeriesCollection(5).XValues = "='All mvt'!$AR$27:$AR$300"
    ActiveChart.SeriesCollection(5).Values = "='All mvt'!$AS$27:$AS$300"
    ActiveChart.SeriesCollection(5).Select
    With Selection.Format.Line
        .Visible = msoTrue
        .ForeColor.RGB = RGB(146, 208, 80)
    End With
    With Selection.Format.Line
        .Visible = msoTrue
        .ForeColor.RGB = RGB(146, 208, 80)
        .Transparency = 0
    End With
    With Selection.Format.Line
        .Visible = msoTrue
        .DashStyle = msoLineSysDash
    End With
    ActiveChart.ChartArea.Select
    ActiveChart.SeriesCollection.NewSeries
    ActiveChart.SeriesCollection(6).Name = "=""Retour RE"""
    ActiveChart.SeriesCollection(6).XValues = "='All mvt'!$AW$27:$AW$300"
    ActiveChart.SeriesCollection(6).Values = "='All mvt'!$AX$27:$AX$300"
    ActiveChart.SeriesCollection(6).Select
    With Selection.Format.Line
        .Visible = msoTrue
        .ForeColor.RGB = RGB(146, 208, 80)
    End With
    With Selection.Format.Line
        .Visible = msoTrue
        .ForeColor.RGB = RGB(255, 0, 0)
        .Transparency = 0
    End With
    With Selection.Format.Line
        .Visible = msoTrue
        .DashStyle = msoLineSysDash
    End With
' Ajustement des vitesses sujet RI RE et All mvt'
' Supprimer tous les 0 de la colonne D puis supprimer les 2 dernières valeurs de la colonne D'

Sheets("Sujet RI").Select
    For i = 3 To 1000        'de la ligne à la ligne
    For j = 4 To 4           'de la colonne à la colonne'
    If Cells(i, j) <= 0 Then
    Cells(i, j).ClearContents 'Font.Bold = True
    End If
    Next j
    Next i

    i = 3
    While Not IsEmpty(Cells(i, 3))      ' tant qu'il y a des valeurs (i,X)'
        If IsEmpty(Cells(i, 4)) Then    ' je remets des 0 dans la colonne (i,Y)'
            Cells(i, 9).Value = 0
        End If
        i = i + 1
    Wend

    ' Supprimme les 2 dernière valeurs de la colonne indiqué dans le Range en remontant à partir de la valeur entre () '
    LaDerniere = Range("D1000").End(xlUp).Offset(0, 0).Select
    Selection.ClearContents
    LaDerniere = Range("D1000").End(xlUp).Offset(0, 0).Select
    Selection.ClearContents

Sheets("Sujet RE").Select
    For i = 3 To 1000        'de la ligne à la ligne
    For j = 4 To 4           'de la colonne à la colonne'
    If Cells(i, j) <= 0 Then
    Cells(i, j).ClearContents
    End If
    Next j
    Next i

    i = 3
    While Not IsEmpty(Cells(i, 3))      ' tant qu'il y a des valeurs (i,X)'
        If IsEmpty(Cells(i, 4)) Then    ' je remets des 0 dans la colonne (i,Y)'
            Cells(i, 9).Value = 0
        End If
        i = i + 1
    Wend

    ' Supprimme les 2 dernière valeurs de la colonne indiqué dans le Range en remontant à partir de la valeur entre () '
    LaDerniere = Range("D1000").End(xlUp).Offset(0, 0).Select
    Selection.ClearContents
    LaDerniere = Range("D1000").End(xlUp).Offset(0, 0).Select
    Selection.ClearContents

Sheets("All mvt").Select
    For i = 3 To 1000        'de la ligne à la ligne
    For j = 4 To 4           'de la colonne à la colonne'
    If Cells(i, j) <= 0 Then
    Cells(i, j).ClearContents
    End If
    Next j
    Next i

    i = 3
    While Not IsEmpty(Cells(i, 3))      ' tant qu'il y a des valeurs (i,X)'
        If IsEmpty(Cells(i, 4)) Then    ' je remets des 0 dans la colonne (i,Y)'
            Cells(i, 9).Value = 0
        End If
        i = i + 1
    Wend

    ' Supprimme les 2 dernière valeurs de la colonne indiqué dans le Range en remontant à partir de la valeur entre () '
    LaDerniere = Range("D1000").End(xlUp).Offset(0, 0).Select
    Selection.ClearContents
    LaDerniere = Range("D1000").End(xlUp).Offset(0, 0).Select
    Selection.ClearContents

Sheets("Sujet RI").Select

Application.ScreenUpdating = True 'fin pour accélérer la macro c'est facultatif c'est une histoire d'affiche
Le 17/02/2015 à 13:43

Juste à première vue (si je vois bien):

dans ce loop, tu n'as pas de sortie:

Value = 99999   
'...
        If Cells(i, j) < Value Then     'changer le signe si on cherche la plus petite
            Value = Cells(i, j)
            Value2 = Cells(i, j - 1)
        End If

Donc soit: a) limite la valeur de "Value" ou b) ajoute une sortie dans ton If...

Le 17/02/2015 à 13:51

Bonjour

Tu écris :

une astuce globale pour accélérer le tout ( style Application.ScreenUpdating )

Cette instuction fait effectivement gagner du temps mais il vaut mieux la mettre en début de macro.

m'indiquer quels types de lignes de code est vraiment mal écrite et ralentie l'exécution

Mal écrites non mais qui pourrait te faire gagner du temps en les écrivant autrement.

Je vois en effet beaucoup de ‘’.select’’ qui sont à éviter si on veut accéler.

Exemple. Tu as :

Sheets("Sujet RE").Select
Range("B24:C24").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy

Tu peux l’écrire ainsi

Sheets("Sujet RE").Range("B24:C24"). Range(Selection, Selection.End(xlDown.Copy

Et comme ce genre d’instructions revient souvent dans ton code, en condensant, tu devrais améliorer les choses.

Bon courage !

Bye !

Le 17/02/2015 à 13:57

Et encore:

1) vire aussi toutes les lignes avec les "scrolls"...

exemple:

    ActiveWindow.SmallScroll Down:=-45
    ActiveWindow.SmallScroll ToRight:=5

Elles ne servent strictement à rien... A part à ralentir le code.

2) il y a des instructions qui se répétent. Tu peux nettoyer tout cela aussi:

exemple (deux fois la même instruction):

    ' Supprimme les 2 dernière valeurs de la colonne indiqué dans le Range en remontant à partir de la valeur entre () '
    LaDerniere = Range("D1000").End(xlUp).Offset(0, 0).Select
    Selection.ClearContents
    LaDerniere = Range("D1000").End(xlUp).Offset(0, 0).Select
    Selection.ClearContents

Edit: ah, j'ai compris pourquoi tu utilises cela. Utilise alors plutôt ceci (ce n'est pas très "propre" mais cela fera l'affaire!):

Range("D1000").End(xlUp).ClearContents
Range("D1000").End(xlUp).ClearContents

Au moins tu ne dois pas a) chipoter avec les sélections (voir la réponse de gmb) et b) tu n'updates pas le contenu de la variable

Le 17/02/2015 à 14:01

Bonjour,

Je ne vois pas comment on peut y arriver sans avoir le fichier sous les yeux.

A+

Le 17/02/2015 à 14:24
Excel-Malin a écrit :

Juste à première vue (si je vois bien):

dans ce loop, tu n'as pas de sortie:

Value = 99999   
'...
        If Cells(i, j) < Value Then     'changer le signe si on cherche la plus petite
            Value = Cells(i, j)
            Value2 = Cells(i, j - 1)
        End If

Donc soit: a) limite la valeur de "Value" ou b) ajoute une sortie dans ton If...

Merci je vais prendre l'option a)

Excel-Malin a écrit :

Et encore:

1) vire aussi toutes les lignes avec les "scrolls"...

exemple:

    ActiveWindow.SmallScroll Down:=-45
    ActiveWindow.SmallScroll ToRight:=5

Elles ne servent strictement à rien... A part à ralentir le code.

2) il y a des instructions qui se répétent. Tu peux nettoyer tout cela aussi:

exemple (deux fois la même instruction):

    ' Supprimme les 2 dernière valeurs de la colonne indiqué dans le Range en remontant à partir de la valeur entre () '
    LaDerniere = Range("D1000").End(xlUp).Offset(0, 0).Select
    Selection.ClearContents
    LaDerniere = Range("D1000").End(xlUp).Offset(0, 0).Select
    Selection.ClearContents

Edit: ah, j'ai compris pourquoi tu utilises cela. Utilise alors plutôt ceci (ce n'est pas très "propre" mais cela fera l'affaire!):

Range("D1000").End(xlUp).ClearContents
Range("D1000").End(xlUp).ClearContents

Au moins tu ne dois pas a) chipoter avec les sélections (voir la réponse de gmb) et b) tu n'updates pas le contenu de la variable

1) Yes je me disais bien que ça servait pas à grand chose des SmallScroll je vais pouvoir les supprimer sans complexes

2) Je dois supprimer les 2 dernières cases de la colonne D du coup j'ai mis 2 fois la même consigne ^^

gmb a écrit :

Bonjour

Tu écris :

une astuce globale pour accélérer le tout ( style Application.ScreenUpdating )

Cette instuction fait effectivement gagner du temps mais il vaut mieux la mettre en début de macro.

m'indiquer quels types de lignes de code est vraiment mal écrite et ralentie l'exécution

Mal écrites non mais qui pourrait te faire gagner du temps en les écrivant autrement.

Je vois en effet beaucoup de ‘’.select’’ qui sont à éviter si on veut accéler.

Exemple. Tu as :

Sheets("Sujet RE").Select
Range("B24:C24").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy

Tu peux l’écrire ainsi

Sheets("Sujet RE").Range("B24:C24"). Range(Selection, Selection.End(xlDown.Copy

Et comme ce genre d’instructions revient souvent dans ton code, en condensant, tu devrais améliorer les choses.

Bon courage !

Bye !

1/ yes je l'ai mis au début et à la fin de la macro le code avec Application.ScreenUpdating

2/ J'ai une erreur de parenthèse avec la Sheets("Sujet RE").Range("B24:C24"). Range(Selection, Selection.End(xlDown.Copy et je ne sais pas trop où la caser la parenthèse :/

Je suppose aussi que le code suivant peut être groupé ?

Sheets("All mvt").Select

Range("W24").Select

ActiveSheet.Paste

galopin01 a écrit :

Bonjour,

Je ne vois pas comment on peut y arriver sans avoir le fichier sous les yeux.

A+

Honnêtement ça serait très très compliqué à expliqué avec le fichier en plus. Je savais qu'il y avait des codes qu'on peut réécrire plus proprement pour gagner du temps et que cela ne demandaient pas d'avoir le fichier sous les yeux (vous vous serez tiré les cheveux avec le fichier ce que je ne souhaite pas ^^)

Le 17/02/2015 à 14:37

1) il en manque deux. Comme ça:

Sheets("Sujet RE").Range("B24:C24"). Range(Selection, Selection.End(xlDown)).Copy

2) oui:

Sheets("All mvt").Range("W24").Select
ActiveSheet.Paste
Le 17/02/2015 à 15:47

Etrange car en remplaçant

Sheets("Sujet RE").Select

Range("B24:C24").Select

Range(Selection, Selection.End(xlDown)).Select

Selection.Copy

Par :

Sheets("Sujet RE").Range("B24:C24"). Range(Selection, Selection.End(xlDown)).Copy

Dans le début de la macro à savoir :

Sheets("Sujet RE").Select

Range("B24:C24").Select

Range(Selection, Selection.End(xlDown)).Select

Selection.Copy

Sheets("All mvt").Select 'copier dans All mvt'

ActiveWindow.SmallScroll Down:=-141

Range("B24").Select

Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

:=False, Transpose:=False

Je me tape l'erreur d'exécution 1004

Le 17/02/2015 à 15:57
heislsim a écrit :

Etrange car en remplaçant

Sheets("Sujet RE").Select

Range("B24:C24").Select

Range(Selection, Selection.End(xlDown)).Select

Selection.Copy

Par :

Sheets("Sujet RE").Range("B24:C24"). Range(Selection, Selection.End(xlDown)).Copy

Dans le début de la macro à savoir :

Sheets("Sujet RE").Select

Range("B24:C24").Select

Range(Selection, Selection.End(xlDown)).Select

Selection.Copy

Sheets("All mvt").Select 'copier dans All mvt'

ActiveWindow.SmallScroll Down:=-141

Range("B24").Select

Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

:=False, Transpose:=False

Je me tape l'erreur d'exécution 1004

C'est correct comme ceci:

Range(Range("B24:C24"), Range("B24:C24").End(xlDown)).Copy

Le tout:

    Sheets("Sujet RE").Select
    Range(Range("B24:C24"), Range("B24:C24").End(xlDown)).Copy
    Sheets("All mvt").Select
    Range("B24").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Le 17/02/2015 à 15:59

Bonsoir,

Honnêtement ça serait très très compliqué à expliqué avec le fichier en plus. Je savais qu'il y avait des codes qu'on peut réécrire plus proprement pour gagner du temps et que cela ne demandaient pas d'avoir le fichier sous les yeux (vous vous serez tiré les cheveux avec le fichier ce que je ne souhaite pas ^^)

Je ne demande pas d'autres explications... Juste le fichier !

Une macro est une pièce d'horlogerie : On ne fait pas un programme avec des bouts de code à la queue-leu-leu.

Il faut déboguer... et déboguer sans fichier ?

De plus la stricte réduction des Select ou des SmallScroll risque de ne pas apporter grand chose.

Alors qu'il existe des méthodes d'optimisation autrement efficace...

A+

Le 17/02/2015 à 17:03

Shit, je n'arrive pas à adapter la partie collage pour des séquences comme ceci

Séquence de base

Sheets("Sujet RI").Select 'Retour RI'

Range("S24:T24").Select

Range(Selection, Selection.End(xlDown)).Select

Selection.Copy

Sheets("All mvt").Select

Range("T24").Select

ActiveSheet.Paste

La version provisoire :

Sheets("Sujet RI").Select 'Retour RI'

Range(Range("S24:T24"), Range("S24:T24").End(xlDown)).Copy

Sheets("All mvt").Select

Range("T24").Select

ActiveSheet.Paste

je pensais que je pouvais supprimer Select ActiveSheet pour mettre bout à bout les 2 lignes comme l'exemple au dessus avec le collage spécial mais non :/

@ galopin01

Merci, j'avoue que l'idéal serait ça mais honnêtement, je n'ai pas l'âme à vous déranger à ce point là car c'est vraiment lourd comme boulot. Je souhaite me parfaire un peu plus en apprenant déjà un peu plus les bonnes manières d'écrire mais tout recommencer depuis le début non car je l'utilise déjà actuellement (c'est un fichier de base de traitement de donnée pour mon mémoire et j'ai une 100ène d'heure de traitement à faire avec et bien sur à faire le plus rapidement possible alors là c'est des secondes bonus de gagné + un peu plus d'apprentissage que je cherche là ^^ )

Rechercher des sujets similaires à "acceleration macro"