Optimiser le temps d'une macro

[Nougies]

Bonjour à tous,

Je suis novice sur ce forum et je soouhaite réduire le temps de ma macro sur excel.
Je m'explique, j'ai une macro qui me permet de réunir plusieurs onglet dans un seul : récapitulatif. Mais le temps d'exécution est trés long.

Voici la macro en question :

Sub Recapitulatif()
Dim Source As Worksheet
Dim Recap As Worksheet
Dim Donnees As New Collection
Dim Cellule As Range
Dim Donnee As String
Dim Element As Variant

' Récupération des données des onglets
' On itère sur toutes les feuilles du classeur
For Each Source In ThisWorkbook.Worksheets
' Si le nom commence par Res_, on ajoute les données à la collection
If Left(Source.Name, 4) = "Sal_" Then
For Each Cellule In Source.Range("a10:a" & Source.Range("a15000").End(xlUp).Row)
' Concaténation des données
Donnee = Cellule & ";" & Cellule(1, 2) & ";" & Cellule(1, 3) & ";" & Cellule(1, 4) & ";" & Cellule(1, 5) & ";" & Cellule(1, 6) & ";" & Cellule(1, 7) & ";" & Cellule(1, 8) & ";" & Cellule(1, 9) & ";" & Cellule(1, 10)
' Ajout de l'élement dans la collection
Donnees.Add Donnee
Next Cellule
End If
Next Source

' Création de la liste dans l'onglet récapitulatif
Set Recap = Worksheets("Recapitulatif")
' Vidange de la feuille de récap
Recap.Range("b2:iv15000").ClearContents
' Itération sur les éléments de la collection
For Each Element In Donnees
' Renvoie la cellule en A si élément présent, sinon NOTHING
Set Cellule = CelluleRecap(Recap, Element)
' Si élément présent, on ajoute les valeurs aux valeurs présentes
If Not Cellule Is Nothing Then



Else
' Sinon, on ajoute une ligne avec les valeurs
Set Cellule = Recap.Range("b15000").End(xlUp)(2)
Cellule(1, 1) = Split(Element, ";")(0)
Cellule(1, 2) = Split(Element, ";")(1)
Cellule(1, 3) = Split(Element, ";")(2)
Cellule(1, 4) = Split(Element, ";")(3)
Cellule(1, 5) = Split(Element, ";")(4)
Cellule(1, 6) = Split(Element, ";")(5)
Cellule(1, 7) = Split(Element, ";")(6)
Cellule(1, 8) = Split(Element, ";")(7)
Cellule(1, 9) = Split(Element, ";")(8)
Cellule(1, 10) = Split(Element, ";")(9)

End If
Next Element

End Sub

Function CelluleRecap(Feuille As Worksheet, ByVal Nom As String) As Range
' Si Nom est présent dans la colonne A de Feuille, renvoie la cellule en A
' Sinon, l'objet retourné est NOTHING
Dim Cellule As Range

For Each Cellule In Feuille.Range("a10:a" & Feuille.Range("a15000").End(xlUp).Row)
If Split(Nom, ";")(0) = Cellule.Value Then
Set CelluleRecap = Cellule
Exit For
End If
Next Cellule
End Function



Merci d'avance à tous ceux qui m'aideront dans cette tâche

 

[Pyrof]

Re : Optimiser le temps d'une macro

Bonjour,

ajoute au début de ta macro

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

et à la fin

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

ça devrait déjà réduire le temps

 

[Nougies]

Re : Optimiser le temps d'une macro

Merci beaucoup cette réponse me convient parfaitement

 

[vbacrumble]

Re : Optimiser le temps d'une macro

Bonjour


Nougies: un petit service svp
Peux-tu éditer, stp, ton message (pour le confort de lecture) et utiliser les balises [ code] [ /code] (supprimer les espaces ).

Merci.

Plus de détails ici:
BB code


Ma petite contribution à ton souci d'optimisation 😉

Sub Recapitulatif()
Dim Source As Worksheet, Recap As Worksheet
Dim Donnees As New Collection, Cellule As Range
Dim Donnee$, Element
' Récupération des données des onglets
' On itère sur toutes les feuilles du classeur
Application.ScreenUpdating = False
For Each Source In ThisWorkbook.Worksheets
' Si le nom commence par Res_, on ajoute les données à la collection
If Source.Name Like "Sal_*" Then
For Each Cellule In Source.Range("a10:a" & Source.Range("a15000").End(xlUp).Row)
' Concaténation des données
Donnee = Cellule & ";" & Cellule(1, 2) & ";" & Cellule(1, 3) & ";" & Cellule(1, 4) & ";" & Cellule(1, 5) & ";" & Cellule(1, 6) & ";" & Cellule(1, 7) & ";" & Cellule(1, 8) & ";" & Cellule(1, 9) & ";" & Cellule(1, 10)
' Ajout de l'élement dans la collection
Donnees.Add Donnee
Next Cellule
End If
Next Source
' Création de la liste dans l'onglet récapitulatif
Set Recap = Worksheets("Recapitulatif")
' Vidange de la feuille de récap
Recap.Range("b2:iv15000") = ""
' Itération sur les éléments de la collection
For Each Element In Donnees
' Renvoie la cellule en A si élément présent, sinon NOTHING
Set Cellule = CelluleRecap(Recap, Element)
' Si élément présent, on ajoute les valeurs aux valeurs présentes
If Not Cellule Is Nothing Then
Else
' Sinon, on ajoute une ligne avec les valeurs
Set Cellule = Recap.Range("b15000").End(xlUp)(2)
For i = 0 To 9
Cellule(1, i + 1) = Split(Element, ";")(i)
Next
End If
Next Element
Application.ScreenUpdating = True
End Sub