Ne pas recalculer les functions d'un module lors de l'execution d'une macro

kaiser

XLDnaute Occasionnel
Re bonjour

Voila sur une feuille j'ai un programme en VBA qui ,en fonction de la couleur des cases, va remplir un fichier annexe (en demandant deux infos via un inputbox) puis l'enregistrer sur une autre nom.
Code:
Private Sub CommandButton1_Click()

Dim Cell As Range
Dim flag As Boolean

feuille = ActiveSheet.Name
Application.ScreenUpdating = False

For n = 9 To Range("B65536").End(xlUp).Row Step 3
If n = 30 Then n = 33
Workbooks.Open "c:\Documents And Settings\diaquint\My Documents\rpl.xls"
Workbooks("2007Schicht2modif1.xls").Activate
Set plage_date = Range("D" & n & ":AG" & n)

i = 6

   For Each Cell In plage_date
    If Cell.Interior.ColorIndex = 6 Or Cell.Interior.ColorIndex = 38 Then
    Application.ScreenUpdating = True
    If Not Cell.Comment Is Nothing Then Cell.Comment.Visible = True
    flag = True
        
    i = i + 1
    nom = Range("B" & n)
    prenom = Range("B" & n + 1)
    Workbooks("rpl.xls").Sheets("sheet1").Range("E4") = prenom & " " & nom
    Workbooks("rpl.xls").Sheets("sheet1").Range("E4").Borders.LineStyle = xLineStyleNone
    Workbooks("rpl.xls").Sheets("sheet1").Range("E28") = "Fait le " & Date
    Workbooks("rpl.xls").Sheets("sheet1").Range("E28").Font.Bold = True
    heure = Cell.Value
    jour = Cells(6, Cell.column)
     Application.ScreenUpdating = False
         Select Case feuille
         .....
         End Select
         
    Workbooks("rpl.xls").Worksheets("sheet1").Range("G3") = mois
    With Workbooks("rpl.xls").Worksheets("sheet1").Range("G3").Font
    .Bold = False
    .Italic = False
    .Underline = False
    End With
    Workbooks("rpl.xls").Worksheets("sheet1").Cells(i, 2) = heure
    Workbooks("rpl.xls").Worksheets("sheet1").Cells(i, 4) = jour & " " & mois

    remplace = InputBox("Entrez le nom de la personne remplacée le " & jour & " " & mois & " par " & prenom & " " & nom, "Remplacement", lastname, 9960, 330)
    Workbooks("rpl.xls").Worksheets("sheet1").Cells(i, 5) = remplace
    lastname = remplace
    If Cell.Interior.ColorIndex = 38 Then
    poste = "Neutra"
    Else
    poste = InputBox("Entrez le poste", "Remplacement", lastposte, 9960, 330)
    lastposte = poste
    End If
    Workbooks("rpl.xls").Worksheets("sheet1").Cells(i, 6) = poste
    'explication = InputBox("Entrez les explications du remplacement", "Remplacement", "", 9960, 330)
    'Workbooks("rpl.xls").Worksheets("sheet1").Cells(i, 7) = explication
    If Not Cell.Comment Is Nothing Then Cell.Comment.Visible = False
 End If
Next Cell
If flag Then
Workbooks("rpl.xls").Activate
Workbooks("rpl.xls").SaveAs Filename:="remplacement " & mois & " " & nom
End If
flag = False
Next n
Workbooks("2007Schicht2modif1.xls").Activate
Workbooks("rpl.xls").Close
Application.ScreenUpdating = True
reponse = MsgBox("Voulez-vous imprimer les fiches de remplacements?", vbYesNo + vbQuestion, "Impression Fiche de Remplacement")
If reponse = 6 Then
If reponse = 7 Then

End If
End If
End Sub

Seulement sur cette même feuille j'ai également 3 fonctions écrites dans un module qui permettent de faire la somme en fonction de la couleur de la case/de la police.

Code:
Function sum_color(plage As Range, couleur_int As Integer) As Integer
    Dim gw_cel As Range, nb As Integer
    'Application.Volatile
    nb = 0
    For Each gw_cel In plage
        If gw_cel.Interior.ColorIndex = couleur_int Then nb = nb + gw_cel.Value
    Next
    sum_color = nb
End Function

Function sum_font_color(plage_date As Range, plage As Range, couleur_font As Integer) As Integer
    'Application.Volatile
    Dim gw_cel As Range, nb As Byte
    nb = 0
    For Each gw_cel In plage
        If Cells(plage_date.Row, gw_cel.column).Interior.ColorIndex = -4142 And gw_cel.Font.ColorIndex = couleur_font Then nb = nb + gw_cel.Value
    Next
    sum_font_color = nb
End Function

Function sum_nuits(plage_date As Range, plage As Range, couleur_int As Integer, couleur_font As Integer)
    'Application.Volatile
    Dim gw_cel As Range, nb As Byte
    nb = 0
    For Each gw_cel In plage
        If Cells(plage_date.Row, gw_cel.column).Interior.ColorIndex = couleur_int And gw_cel.Font.ColorIndex = couleur_font Then nb = nb + gw_cel.Value
    Next
    sum_nuits = nb
End Function

Le probléme qui se pose c'est que lors de l'éxécution de la macro, il recalcule en permanence les fonctions ce qui ralentit énormément le déroulement de la macro: cela est du a la ligne "application.volatile" qui fais qu'il recalcule a chaque regeneration de la page, mais si je supprime le "application.volatile", la les fonctions ne sont plus du tout recalculées!

Merci de votre aide
 

wilfried_42

XLDnaute Barbatruc
Re : Ne pas recalculer les functions d'un module lors de l'execution d'une macro

Bonjour kaiser

Private Sub CommandButton1_Click()

Dim Cell As Range
Dim flag As Boolean

feuille = ActiveSheet.Name
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
.
.
.
.
.
.
.
.
.
.

End If
Application.Calculation = xlCalculationAutomatic
End Sub
 

Gorfael

XLDnaute Barbatruc
Re : Ne pas recalculer les functions d'un module lors de l'execution d'une macro

Salut kaiser
comme j'ai pas envie de perdre du temps si ce n'est pas nécessaire, je te propose une solution qui me semble simple : au lancement de ta macro, tu passes en calcul manuel, en sortie de ta macro, tu le repasses en automatique et tu fais effectuer un calcul (calculate)

Comme je n'utilises pas de Function, je ne sais pas si les instructions

Application.ScreenUpdating = False
Application.EnableEvents = False
ne seraient pas mieux

Mais dans tout les cas, une gestion des erreurs s'impose. Pour moi, je testerais
Code:
Private Sub CommandButton1_Click()
On Error GoTo Err_CommandButton1_Click
Application.ScreenUpdating = False
Application.EnableEvents = False
 
----- Ton code -----
 
Sortie_CommandButton1_Click:
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    ActiveSheet.Calculate
    Exit Sub
Err_CommandButton1_Click:
    MsgBox (Err.Number & " - " & Err.Description)
    Resume Sortie_CommandButton1_Click
End Sub
Ou bien, en remplaçant

Application.EnableEvents = False par Application.Calculation = xlManual
et
Application.EnableEvents = True par Application.Calculation = xlAutomatic
ça devrait suffire, mais comme je n'ai pas testé, c'est à vérifier.

Petite remarque en passant : chaque fois que j'utilise une instruction mettant en cause Application, je fais une gestion des erreurs.
Je sais, c'est chiant et ça n'apporte pas grand chose. Mais comme je ne suis pas un SuperProgrammeur, il m'arrive de ne pas blinder assez mon code et d'avoir des erreurs.
Comme Excel est gentil, il prend la main et me signale l'erreur, puis il sort. Il ne continue pas, il arrête directement la macro à l'endroit de l'erreur. Ce qui fait que l'instruction de rétablissement des modifications de l'Application n'est pas exécutée.
Assez amusant, parce que, en général, vous vous occupez de ce qui a généré l'erreur, mais que vous oubliez la modif de l'application en cours : sublime avec EnableEvents ou ScreenUpDating

Donc, après avoir perdu une bonne partie de ma cheveulure, je gère les erreurs

A+
 
Dernière édition:

kaiser

XLDnaute Occasionnel
Re : Ne pas recalculer les functions d'un module lors de l'execution d'une macro

J'ai testé ce que tu as dis Wilfried mais ca ne marche pas!

Rien qu'avec une feuille ou j'ai que 5 case a comptabiliser je perd toujours 3secondes, alors je te raconte pas quand il y en a 50...

Edit:j'avais pas vu le post de gorfael, je test
 
Dernière édition:

wilfried_42

XLDnaute Barbatruc
Re : Ne pas recalculer les functions d'un module lors de l'execution d'une macro

re: boujour Gorfael

De toute facon, j'ai vu que dans les fonctions

Appliction.volatile etaient en remarque, donc elle ne sont calculées qu'à la demande et ce ne sont pas elles qu'il faut incriminer, il y a autre chose
 

kaiser

XLDnaute Occasionnel
Re : Ne pas recalculer les functions d'un module lors de l'execution d'une macro

j'avais mis les applications.volatile en commentaire car je faisait pas de test pour le programme et j'avais pas envie de perdre du temps pour rien.

J'ai testé ce que garfuel a mis, et en chronométrant avec mon portable je trovue toujours un écart de 2-3sec (pour le cas avec 5cases correspond au critére)
 

wilfried_42

XLDnaute Barbatruc
Re : Ne pas recalculer les functions d'un module lors de l'execution d'une macro

re:

une question : A la fin de la macro, tu as combien de fichier ouverts ?

je m'explique :

Private Sub CommandButton1_Click()

Dim Cell As Range
Dim flag As Boolean

feuille = ActiveSheet.Name
Application.ScreenUpdating = False

For n = 9 To Range("B65536").End(xlUp).Row Step 3
If n = 30 Then n = 33
Workbooks.Open "c:\Documents And Settings\diaquint\My Documents\rpl.xls"
Workbooks("2007Schicht2modif1.xls").Activate
.
.
.
.
.
.
.
.
.
Workbooks("rpl.xls").Activate
Workbooks("rpl.xls").SaveAs Filename:="remplacement " & mois & " " & nom
ThisWorkbook.close
End If
flag = False
Next n

Workbooks("2007Schicht2modif1.xls").Activate
Workbooks("rpl.xls").Close
End Sub

en bleu, tu as ta boucle
je ne vois aucune fermetur de fichier à l'interieur de cette boucle alorsque tu en ouvres un à chaque fois

tu ouvres : "c:\Documents And Settings\diaquint\My Documents\rpl.xls" au début.

Tu le sauvegardes sous un autre nom à la fin mais tu ne le fermes jamais
je verrai bien le code en Vert

@ te lire
 

kaiser

XLDnaute Occasionnel
Re : Ne pas recalculer les functions d'un module lors de l'execution d'une macro

juste avant la fin du progranne j'ai le fichier rpl.xls d'ouvert (c'est à dire le fichier vierge) + autant de fichier que de personne ayant fait de remplacement ( c'est à dire généralement 4/5).

A la fin du programme je ferme bien le rpl.xls avec la ligne "Workbooks("rpl.xls").Close"
 

wilfried_42

XLDnaute Barbatruc
Re : Ne pas recalculer les functions d'un module lors de l'execution d'une macro

re:

c'est ce que je dis, tous les fichiers qui on fait l'objet d'un remplacement restent ouverts, c'est surement normal (c'est selon ton desiderata).......
Mais cela doit prendre de la place en memoire et doit te freiner ta macro...
 

kaiser

XLDnaute Occasionnel
Re : Ne pas recalculer les functions d'un module lors de l'execution d'une macro

ah oki petit malentendu entre nous, en fait les fichiers annexe qui sont sauvegardés peuvent être soumis a des "personalisation" c'est pour cela que j'ai choisis des les laisser ouvert

j'ai deja supprimé le "Workbooks("rpl.xls").Activate" à la fin du programme qui ne servait plus à rien et le programme a un peu gagner en vitesse d'éxécution.
 

Gorfael

XLDnaute Barbatruc
Re : Ne pas recalculer les functions d'un module lors de l'execution d'une macro

Salut kaiser, wilfried_42 et le forum
je ne me suis pas penché sur la macro, parce qu'elle n'est pas entière et qu'avec les coupures dues à la largeur de la page internet, c'est dur de savoir si tu emploies la forme If....Then ou if...Then...end if (par exemple)

Tu multiplies les instructions ScreenUpDating. Pourquoi ? Tu as besoin de voir ce qui se passe ?

Tu parles de 3/4 secondes, alors qu'il semble y avoir des boîtes de dialogue

ta boucle "For Each Cell In plage_date"
tu réécris à chaque passage en forme et/ou en valeur les cellules E4, E28, G3

Pour le test
If flag Then
Workbooks("rpl.xls").Activate
Workbooks("rpl.xls").SaveAs Filename:="remplacement " & mois & " " & nom
End If
flag = False
Pourquoi remettre à faux Flag, s'il l'est déjà ?
pourquoi activer rpl.xls ?
If flag Then
Workbooks("rpl.xls").SaveAs Filename:="remplacement " & mois & " " & nom
flag = False

End If
ça change pas grand chose, mais...

Le problème, vu de mon coté est que je n'ai pas assez d'infos. pour accélérer une macro, il faut trouver la cause du ralentissement : ce n'est pas parce qu'on pense qu'une suite d'instruction retarde ou accélère le déroulement que c'est forcément vrai. 3 secondes ne permet pas de juger : tu as d'autres applications qui tournent, et peut-être que l'une d'elle génère un manque de ressources. Avec tes 50 cases, tu serais peut-être à 7 ou 8 secondes. Et en plus, il faut être sûr qu'il n'y a pas d'interférences homme/machine :D

J'ai déjà fait des tests de rapidité de code : sur des boucles for X=..., for each...., do.... et While...
et comme je voulais vraiment savoir, sur 60000 valeurs, 10 fois de suite :
les 10 résultats de chaques boucles étaient non-significatifs, parce que toutes avaient des résultats allant du simple à dix fois le temps :eek:

A+
 

kaiser

XLDnaute Occasionnel
Re : Ne pas recalculer les functions d'un module lors de l'execution d'une macro

Salut gorfael

Alors je vais répndre a tes questions:
-les instructions screenupdating sont "multipliés" pour que quand le programme trovue une case correspondant à mes critéres j'ai besoin de voir le commentaire de la case si commentaire il y a.

-pour la réécriture des cellules E4, E28, G3 a chaque fois, exact j'avais pas fais gaffe à ca(noob en vba inside!^^) je pense que je vais deplacer tout ca juste avant l'enregistrement du fichier mais aprés le "next Cell"

-pour les flags en fait c'est un membre du forum qui avait ca lorsque j'avais un autre probléme. Lorsqu'on met "If flag Then" ca veut dire que flag est true ou false?

-pourquoi activer rpl.xls?: ca c'est une connerie de ma part, une ligne qui était utile lorsque je comencais le programme mais la elle sert plus a rien, je l'ai deja supprimé hier.

Je vais faire quelque test, je vous tiens au courant.

PS: ca craint j'ai oublié de prendre de la monnaie pour la machine à café aujourd'hui!^^
 

Gorfael

XLDnaute Barbatruc
Re : Ne pas recalculer les functions d'un module lors de l'execution d'une macro

kaiser à dit:
Salut gorfael

Alors je vais répndre a tes questions:
-les instructions screenupdating sont "multipliés" pour que quand le programme trovue une case correspondant à mes critéres j'ai besoin de voir le commentaire de la case si commentaire il y a.

-pour la réécriture des cellules E4, E28, G3 a chaque fois, exact j'avais pas fais gaffe à ca(noob en vba inside!^^) je pense que je vais deplacer tout ca juste avant l'enregistrement du fichier mais aprés le "next Cell"

-pour les flags en fait c'est un membre du forum qui avait ca lorsque j'avais un autre probléme. Lorsqu'on met "If flag Then" ca veut dire que flag est true ou false?

-pourquoi activer rpl.xls?: ca c'est une connerie de ma part, une ligne qui était utile lorsque je comencais le programme mais la elle sert plus a rien, je l'ai deja supprimé hier.

Je vais faire quelque test, je vous tiens au courant.

PS: ca craint j'ai oublié de prendre de la monnaie pour la machine à café aujourd'hui!^^
Salut à tous
If "condition" then "Vrai" else "Faux"
si "condition" =true on effectue Vrai, sinon on effectue Faux
Condition peut être une variable booléenne, une ou plusieurs expressions logiques
A+
NB : Réponse tardive due à un #CENSURÉ# d'incident de DD système :mad:
 

kaiser

XLDnaute Occasionnel
Re : Ne pas recalculer les functions d'un module lors de l'execution d'une macro

Salut a toi

Pas cool ce que qu'est arrivé a ton DD, j'espére que t'a pas perdu trop de fichier important dans l'accident.

J'avais compris le truc des conditions, mais a un endroit vers la fin du programme j'ai "if flag then" et je voulais savoir si quand on est met rien comme ici, si cela signifie True ou False.


Sinon t'aurais pas une ptite idée concernant mes impressions?
 

Gorfael

XLDnaute Barbatruc
Re : Ne pas recalculer les functions d'un module lors de l'execution d'une macro

kaiser à dit:
Salut a toi

Pas cool ce que qu'est arrivé a ton DD, j'espére que t'a pas perdu trop de fichier important dans l'accident.

J'avais compris le truc des conditions, mais a un endroit vers la fin du programme j'ai "if flag then" et je voulais savoir si quand on est met rien comme ici, si cela signifie True ou False.


Sinon t'aurais pas une ptite idée concernant mes impressions?
Salut
if flag then revient à écrire
if flag=True then
Par défaut les variables booléenne sont à False
A+
NB Pour mon DD, presque rien perdu, grâce à PC Inspector File Recovery
 

Statistiques des forums

Discussions
311 725
Messages
2 081 940
Membres
101 845
dernier inscrit
annesof