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.
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.
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
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 SubSeulement 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 FunctionLe 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