Execution Macro très lente

[arckeo72]

Bonjour à tous,

J’exécute la macro suivante et je trouve l’application plutôt lente.

Comme je ne sais pas comment la simplifier je fais appel à vous.

"Sub Macro1()
'
' Macro1 Macro
'

'
ActiveSheet.Range("$A$2:$S$65536").AutoFilter Field:=7, Criteria1:=Range("J1")
Rows("6:6").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Range("A6").Select
ActiveCell.FormulaR1C1 = "=R[1]C"
Range("B6").Select
ActiveCell.FormulaR1C1 = "=R[1]C+1"
Range("C6").Select
ActiveCell.FormulaR1C1 = "=R[1]C"
Range("D6").Select
ActiveCell.FormulaR1C1 = "=TODAY()"
Range("F7").Select
Selection.Copy
Range("F6").Select
ActiveSheet.Paste
Range("H7").Select
Selection.Copy
Range("H6").Select
ActiveSheet.Paste
Range("J7").Select
Selection.Copy
Range("J6").Select
ActiveSheet.Paste
Range("J1").Select
Selection.Copy
Range("G6").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

End Sub"


A noter l'execution de ma macro se fait via celle-ci :

"Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$J$1" Then Call Macro1
End Sub"

D'avance merci.

 

[Efgé]

Re : Execution Macro très lente

Bonjour arckeo72
Au plus simple, il est inutile d'utiliser tous ces vilains Select

Sub Macro2()
Application.ScreenUpdating = False 'bloquer l'affichage écran
ActiveSheet.Range("$A$2:$S$65536").AutoFilter Field:=7, Criteria1:=Range("J1")
Rows("6:6").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Range("A6").FormulaR1C1 = "=R[1]C"
Range("B6").FormulaR1C1 = "=R[1]C+1"
Range("C6").FormulaR1C1 = "=R[1]C"
Range("D6").FormulaR1C1 = "=TODAY()"
Range("F7").Copy Range("F6")
Range("H7").Copy Range("H6")
Range("J7").Copy Range("J6")
Range("G6").Value = Range("J1").Value
End Sub

Cordialement

 

[arckeo72]

Re : Execution Macro très lente

Merci beaucoup ça marche nickel.

J'ai également rajouter ceci pour améliorer la vitesse d'exécution :
Au début de la macro
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Avant la fin de la macro
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

Salutations.

 

[oz2007]

Bonjour,

Je m'incruste dans la conversation car j'ai fait une macro qui fonctionne bien mais qui est lente...comment puis l'optimiser en sachant que j'ai utilisé la méthode d'arckeo72. Merciiiii

Sub Macro1()
'
' Macro1 Macro
'
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

'
Application.Dialogs.Item(xlDialogOpen).Show
           Range("A1:AH" & Range("A65536").End(xlUp).Row).SpecialCells(xlCellTypeVisible).Select
    Selection.Copy
    ActiveWindow.Close
    Windows("Cotisations macro.xlsm").Activate
    Range("A1").Select
    ActiveSheet.Paste
   


    Range("AI1").Select
    ActiveCell.FormulaR1C1 = "Doublons"

'Recherche de doublon dans les contrats
    Range("AI2").Select
    ActiveCell.FormulaR1C1 = _
        "=IF(COUNTIF(R2C15:RC[-20],RC[-20])=1,SUMIF(C[-20],RC[-20],C[-4]),"""")"

'Tirer la formule vers le bas
Dim LastRw As Long
LastRw = Sheets("Feuil1").Cells(Rows.Count, 1).End(xlUp).Row
Range("AI2:AI" & LastRw).FillDown


'Analyse les doublons
    Range("AJ1").Select
    ActiveCell.FormulaR1C1 = "Analyse doublons"
    Range("AJ2").Select
    ActiveCell.FormulaR1C1 = "=IF(RC[-1]=1,""Pas de doublon"",""Doublon"")"
    Range("AJ2").Select

'Tirer la formule vers le bas
LastRw = Sheets("Feuil1").Cells(Rows.Count, 1).End(xlUp).Row
Range("AJ2:AJ" & LastRw).FillDown

'Masque la cellule
Columns("AI:AI").Select
Selection.EntireColumn.Hidden = True
   
'Recherche des tarifs chelou
Range("AK1").Select
ActiveCell.FormulaR1C1 = "Analyse tarif"
Range("AK2").Select
ActiveCell.FormulaR1C1 = _
"=IFERROR(VLOOKUP(RC[-17],Tarif!R1C1:R152C2,2,FALSE),""Tarif à contrôler"")"

'Tirer la formule vers le bas
LastRw = Sheets("Feuil1").Cells(Rows.Count, 1).End(xlUp).Row
Range("AK2:AK" & LastRw).FillDown


'Colonne pour resumer les contrôles
Range("AL1").Select
ActiveCell.FormulaR1C1 = "Contrôles"
Range("AL2").Select
ActiveCell.FormulaR1C1 = _
"=IF(OR(RC[-2]=""Doublon"",RC[-1]=""Tarif à contrôler""),""Contrôle à faire"",""Pas de contrôle"")"

'Tirer la formule vers le bas
LastRw = Sheets("Feuil1").Cells(Rows.Count, 1).End(xlUp).Row
Range("AL2:AL" & LastRw).FillDown

'copier coller valeurs pour enlever les formules
Columns("AJ:AL").Select
Range("AL1").Activate
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True


End Sub

 

[Bernard_XLD]

Bonjour

Crées un nouveau fil et mets un fichier exemple pour les tests
en attendant tu devrais gagner un peu de temps sur ton collage de valeurs

'copier coller valeurs pour enlever les formules
Range("AJ1:AL" & Range("AJ65536").End(xlUp).Row).Value = Range("AJ1:AL" & Range("AJ65536").End(xlUp).Row).Value

 

[Efgé]

Bonjour oz2007, Bonjour Yeahou, le fil, le forum
Comme je disais en 2013 (Déjà 4 ans, que le temps passe....):

il est inutile d'utiliser tous ces vilains Select

En 2017 je rajoute
Traiter les colonnes au fur et à mesure et éviter les FillDown:
(J'ai mis en commentaire la partie que je ne peux tester)

Sub Macro1()
Dim LastRw As Long

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'Application.Dialogs.Item(xlDialogOpen).Show
            'Range("A1:AH" & Range("A65536").End(xlUp).Row).SpecialCells(xlCellTypeVisible).Select
     'Selection.Copy
     'ActiveWindow.Close
     'Windows("Cotisations macro.xlsm").Activate
     'Range("A1").Select
     'ActiveSheet.Paste

Range("AI1") = "Doublons"
Range("AJ1") = "Analyse doublons"
Range("AK1") = "Analyse tarif"
Range("AL1") = "Contrôles"
LastRw = Sheets("Feuil1").Cells(Rows.Count, 1).End(xlUp).Row

'Recherche de doublon dans les contrats
With Range("AI2:AI" & LastRw)
    .FormulaR1C1 = "=IF(COUNTIF(R2C15:RC[-20],RC[-20])=1,SUMIF(C[-20],RC[-20],C[-4]),"""")"
    .Value = .Value
End With
'Analyse les doublons
With Range("AJ2:AJ" & LastRw)
    .FormulaR1C1 = "=IF(RC[-1]=1,""Pas de doublon"",""Doublon"")"
    .Value = .Value
    'Masque la cellule
    .EntireColumn.Hidden = True
End With
'Recherche des tarifs chelou
With Range("AK2:AK" & LastRw)
    .FormulaR1C1 = _
        "=IFERROR(VLOOKUP(RC[-17],Tarif!R1C1:R152C2,2,FALSE),""Tarif à contrôler"")"
    .Value = .Value
End With
'Colonne pour resumer les contrôles
With Range("AL2:AL" & LastRw)
    .FormulaR1C1 = _
        "=IF(OR(RC[-2]=""Doublon"",RC[-1]=""Tarif à contrôler""),""Contrôle à faire"",""Pas de contrôle"")"
    .Value = .Value
End With
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

Cordialement