macro trop longue a s'exécuter

[roybaf]

Bonsoir à tous,

Je cherche à raccourcir une macro qui met plus de 5 min à s'exécuter, en effet j'arrive à ce que je veux mais c'est un peu long.

Voici mon code, une grande partie a été obtenue par l'enregistreur :

Private Sub Image2_Click()
Application.ScreenUpdating = False
Dim derlin1 As Integer
Dim derlin2 As Integer
Dim derlin3 As Integer
Dim derlin4 As Integer
Dim derlin5 As Integer
Dim derlin6 As Integer
Dim derlin7 As Integer
Dim derlin8 As Integer
Dim derlin9 As Integer
Dim derlin10 As Integer
derlin1 = Sheets("rentabilité").Range("A" & Rows.Count).End(xlUp).Row + 1
    Sheets("rentabilité").Range("A" & derlin1) = Date
derlin2 = Sheets("indice-marché").Range("A" & Rows.Count).End(xlUp).Row + 1
    Sheets("indice-marché").Range("A" & derlin2) = Date
derlin3 = Sheets("variance").Range("A" & Rows.Count).End(xlUp).Row + 1
    Sheets("variance").Range("A" & derlin3) = Date
derlin4 = Sheets("variance_marché").Range("A" & Rows.Count).End(xlUp).Row + 1
    Sheets("variance_marché").Range("A" & derlin4) = Date
derlin5 = Sheets("covariance").Range("A" & Rows.Count).End(xlUp).Row + 1
    Sheets("covariance").Range("A" & derlin5) = Date
derlin6 = Sheets("rentabilité_marché").Range("A" & Rows.Count).End(xlUp).Row + 1
    Sheets("rentabilité_marché").Range("A" & derlin6) = Date
derlin7 = Sheets("graphique").Range("f" & Rows.Count).End(xlUp).Row + 1
    Sheets("graphique").Range("f" & derlin7) = Date
derlin9 = Sheets("tendance").Range("a" & Rows.Count).End(xlUp).Row + 1
    Sheets("tendance").Range("a" & derlin9) = Date
derlin10 = Sheets("ecarttendance").Range("a" & Rows.Count).End(xlUp).Row + 1
    Sheets("ecarttendance").Range("a" & derlin10) = Date
Dim tablo As Variant
Dim n As Integer
Dim c As Range
Dim derlin As Integer
tablo = Sheets("Cours").Range("B3:I" & Sheets("Cours").Range("B" & Rows.Count).End(xlUp).Row)
derlin = Sheets("historique_cours").Range("A" & Rows.Count).End(xlUp).Row + 1
For n = LBound(tablo, 1) To UBound(tablo, 1)
  Set c = Sheets("historique_cours").Rows(1).Find(tablo(n, LBound(tablo, 2)), LookIn:=xlValues, LookAt:=xlWhole)
  If Not c Is Nothing Then
    Sheets("historique_cours").Range("A" & derlin) = Date
    Sheets("historique_cours").Cells(derlin, c.Column) = tablo(n, LBound(tablo, 2) + 1)
  End If
Next
Application.ScreenUpdating = False
Sheets("indice-marché").Activate
With ActiveSheet.QueryTables.Add(Connection:= _
        "URL;http://www.boursorama.com/cours.phtml?symbole=2zPMS190", Destination:= _
        Range("$E$5"))
        .Name = "indiceweb"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlOverwriteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .WebSelectionType = xlSpecifiedTables
        .WebFormatting = xlWebFormattingNone
        .WebTables = "6"
        .WebPreFormattedTextToColumns = True
        .WebConsecutiveDelimitersAsOne = True
        .WebSingleBlockTextImport = False
        .WebDisableDateRecognition = False
        .WebDisableRedirections = False
        .Refresh BackgroundQuery:=False
    End With
    ActiveCell.Replace What:="Pts", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Cells.Replace What:="Pts", Replacement:="", LookAt:=xlPart, SearchOrder _
        :=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Application.ScreenUpdating = False
Sheets("indice-marché").Select
Dim casefin As Range
Range("F5").Select
Cells.Replace What:="(c)", Replacement:="", LookAt:=xlPart, SearchOrder _
        :=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
    Range("F5").Select
    ActiveCell.Replace What:=".", Replacement:=",", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Cells.Find(What:=".", After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
        xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
        , SearchFormat:=False).Activate
    Range("D1:H3").Select
Set casefin = Worksheets("indice-marché").Range("b3").End(xlDown)
casefin.Offset(1, 0).Value = CDbl(Worksheets("indice-marché").Range("f5").Value)
Cells.Replace What:=" ", Replacement:="", LookAt:=xlPart, SearchOrder:= _
    xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Sheets("menu").Select
Jouer_miseàjourseffectué
Randomize
Unload actualisation
End Sub

Dim derlin1 As Integer
Dim derlin2 As Integer
Dim derlin3 As Integer
Dim derlin4 As Integer
Dim derlin5 As Integer
Dim derlin6 As Integer
Dim derlin7 As Integer
Dim derlin8 As Integer
Dim derlin9 As Integer
Dim derlin10 As Integer
derlin1 = Sheets("rentabilité").Range("A" & Rows.Count).End(xlUp).Row + 1
Sheets("rentabilité").Range("A" & derlin1) = Date
derlin2 = Sheets("indice-marché").Range("A" & Rows.Count).End(xlUp).Row + 1
Sheets("indice-marché").Range("A" & derlin2) = Date
derlin3 = Sheets("variance").Range("A" & Rows.Count).End(xlUp).Row + 1
Sheets("variance").Range("A" & derlin3) = Date
derlin4 = Sheets("variance_marché").Range("A" & Rows.Count).End(xlUp).Row + 1
Sheets("variance_marché").Range("A" & derlin4) = Date
derlin5 = Sheets("covariance").Range("A" & Rows.Count).End(xlUp).Row + 1
Sheets("covariance").Range("A" & derlin5) = Date
derlin6 = Sheets("rentabilité_marché").Range("A" & Rows.Count).End(xlUp).Row + 1
Sheets("rentabilité_marché").Range("A" & derlin6) = Date
derlin7 = Sheets("graphique").Range("f" & Rows.Count).End(xlUp).Row + 1
Sheets("graphique").Range("f" & derlin7) = Date
derlin9 = Sheets("tendance").Range("a" & Rows.Count).End(xlUp).Row + 1
Sheets("tendance").Range("a" & derlin9) = Date
derlin10 = Sheets("ecarttendance").Range("a" & Rows.Count).End(xlUp).Row + 1
Sheets("ecarttendance").Range("a" & derlin10) = Date

à mon avis la partie en rouge peut être optimisée mais quand j'essaie sa me plante, à l'aide!!

Bonsoir à tous.

 

[Dranreb]

Re : macro trop longue a s'exécuter

Bonsoir.
Effectivement, au lieu de

derlin1 = Sheets("rentabilité").Range("A" & Rows.Count).End(xlUp).Row + 1
Sheets("rentabilité").Range("A" & derlin1) = Date

vous pouvez faire:

Worksheets("rentabilité").Range("A" & Rows.Count).End(xlUp).Offset(1).Value = Date

Vous gagneriez encore un peu de temps en utilisant les CodeName des feuilles
Sheets(quelque chose) était le pire: en plus de nécessiter une recherche du nom dans la collection, c'est une collection d'objets banalisés pouvant contenir aussi bien des objets Chart que Worksheet, d'où liaison tardive à la méthode Range de l'objet Worksheet.
Et vous le faisiez chaque fois 2 fois.
Cordialement

 

[goldenboy]

Re : macro trop longue a s'exécuter

Bonsoir,

Vous avez également deux fois : Application.ScreenUpdating = False

Mais vous ne remettez pas cette ligne : Application.ScreenUpdating = True

Je ne connais pas trop l'incidence, mais peut-être que quelqu'un de plus calé pourra nous éclairer.

Cordialement,

 

[sourcier08]

Re : macro trop longue a s'exécuter

Salut à tous,

Effectivement, Application.ScreenUpdating doit s'utiliser de cette manière :

Application.ScreenUpdating = False

'instructions diverses concernant les mouvements visuels dans le classeur

Application.ScreenUpdating = True

Certains ont tendance à dire que ça ne concerne que les cellules. C'est à confirmer de ce côté car, pour moi, dès l'instant où l'on change de feuille, qu'on agit dans des shapes ou des graphiques, on doit aussi l'appliquer.

 

[roybaf]

Re : macro trop longue a s'exécuter

Bonsoir dranreb,

J'ai essayé

Private Sub Image2_Click()
Application.ScreenUpdating = False
Worksheets(Feuil6).Range("A" & Rows.Count).End(xlUp).Offset(1).Value = Date
Worksheets(Feuil16).Range("A" & Rows.Count).End(xlUp).Offset(1).Value = Date
Worksheets(Feuil9).Range("A" & Rows.Count).End(xlUp).Offset(1).Value = Date
Worksheets(Feuil10).Range("A" & Rows.Count).End(xlUp).Offset(1).Value = Date
Worksheets(Feuil11).Range("A" & Rows.Count).End(xlUp).Offset(1).Value = Date
Worksheets(Feuil8).Range("A" & Rows.Count).End(xlUp).Offset(1).Value = Date
Worksheets(Feuil14).Range("f" & Rows.Count).End(xlUp).Offset(1).Value = Date
Worksheets(Feuil19).Range("a" & Rows.Count).End(xlUp).Offset(1).Value = Date
Worksheets(Feuil20).Range("a" & Rows.Count).End(xlUp).Offset(1).Value = Date

mais j'ai le bug sur la première ligne...

une piste?

 

[Dranreb]

Re : macro trop longue a s'exécuter

Si feui6 etc. sont les CodeName des feuilles il ne faut plus spécifier Worksheets(Feuil6): Feuil6 tout seul suffit en tant qu'expression Worksheet. Ce sont en somme des noms de constantes de type Worksheet connues dans le projet VBA. Et qui ne nécessitent donc plus de recherche dans la collection Worksheets: l'accès à l'objet est direct. C'est: Feuil6.Range(etc.
Cordialement.