Rapidité d'exécution macro

[counterbob]

Bonjour
j'ai réalisé ce code mais je le trouve assez lent à se dérouler.
Il y a-t-il un moyen efficace pour que ce code s'exécute plus rapidement ?
Merci

Sub FormOKKO()
'sélection de la cellule H2
Range("H2").Select ' curseur sur A2
'compteur de 1 à 100 à changer jusque 1000
For compteur = 1 To 100
'insere la formule si la valeur de la cellule de gauche est égale à la date du jour
If ActiveCell.Offset(0, -1) = Date Then
ActiveCell.FormulaR1C1 = "=IF(RC[-1]<>TODAY(),""KO"",""OK"")"
' sinon si vide la valeur est vide
If ActiveCell.Offset(0, -1) = "" Then
ActiveCell = ""
End If

End If
ActiveCell.Offset(1, 0).Select
Next compteur

'sélection cellule I2
Range("I2").Select ' curseur sur A1
For compteur = 1 To 100
'si la valeur de la cellule -é de gauche = date du jour
If ActiveCell.Offset(0, -2) = Date Then
ActiveCell.FormulaR1C1 = "=IF(SUM(RC[2]:RC[14])=1,""OK"",IF(RC[-3]=1,""OK"",""KO""))"
If ActiveCell.Offset(0, -2) = "" Then
ActiveCell = ""
End If
End If
ActiveCell.Offset(1, 0).Select
Next compteur

End Sub

 

[pierrejean]

Bonjour counterbob
Oui
Question suivante ? (de préférence avec un petit fichier exemple sans données confidentielles )

 

[counterbob]

Ok voici le fichier
merci

 

[counterbob]

voici un plus correct
la macro s'exécute avec le bouton "Insere Ok KO
elle est dans la feuil(1) vba

Bonjour counterbob
Oui
Question suivante ? (de préférence avec un petit fichier exemple sans données confidentielles )

 

[pierrejean]

Re

Vois si cela va mieux

 

[pierrejean]

Re

Encore

 

[counterbob]

Re

Encore

merci PierreJean, mais ton code ne fait que copier la formule des cellules H2 et I2
Si elles sont vides ou autre chose est saisie dans ces cellules elles seront recopiées dans les autres cellules.
ce n'est pas ce que je veux dans mon code.
Mon code fonctionne bien mais il est trop lent à s’exécuter et je pense qu'il y a mieux.

merci
@+

 

[pierrejean]

Re

Voici une petite accélération
Si besoin de plus on tentera autre chose

 

[job75]

Bonjour counterbob, salut Pierre, heureux de te croiser,

Cette macro fait exactement le même travail que la vôtre mais bien sûr plus rapidement :

Sub FormOKKO()
Application.ScreenUpdating = False
On Error Resume Next 'si pas de SpecialCell
If FilterMode Then ShowAllData 'si la feuille est filtrée
[G:G].Replace Date, "#N/A"
With [G:G].SpecialCells(xlCellTypeConstants, 16)
    Intersect(.EntireRow, [H:H]) = "=IF(RC[-1]<>TODAY(),""KO"",""OK"")"
    Intersect(.EntireRow, [I:I]) = "=IF(OR(SUM(RC[2]:RC[14])=1,RC[-3]=1),""OK"",""KO"")"
End With
[G:G].Replace "#N/A", Date
Intersect([G:G].SpecialCells(xlCellTypeBlanks).EntireRow, [H:I]) = ""
End Sub

Sur votre fichier du post #4 elle s'exécute en 0,027 seconde chez moi alors que votre macro prend 2 secondes.

A+

 

[job75]

Re,

Je préfère cette macro qui utilise le filtre automatique :

Sub FormOKKO()
Dim f$
Application.ScreenUpdating = False
On Error Resume Next 'si pas de SpecialCell
f = [G2].NumberFormat
[G:G].NumberFormat = "0"
[G:G].AutoFilter 1, CLng(Date) 'filtre automatique
With AutoFilter.Range.Offset(1).SpecialCells(xlCellTypeVisible)
    Intersect(.EntireRow, [H:H]) = "=IF(RC[-1]<>TODAY(),""KO"",""OK"")"
    Intersect(.EntireRow, [I:I]) = "=IF(OR(SUM(RC[2]:RC[14])=1,RC[-3]=1),""OK"",""KO"")"
End With
[G:G].AutoFilter
[G:G].NumberFormat = f
Intersect([G:G].SpecialCells(xlCellTypeBlanks).EntireRow, [H:I]) = ""
End Sub

Elle est aussi plus rapide : 0,016 seconde.

Je rappelle que cette macro, comme celle du post précédent, est à placer dans le code de la feuille.

A+

 

[counterbob]

Merci Pierre, merci Job75
Job75 ton code ne fonctionne que si la date du jour est valide dans les cellules colonne G.
J'ai récrit le code avec la ligne : "Application.ScreenUpdating = False" et c'est bon.

Sub FormOKKO()
Application.ScreenUpdating = False
Range("H2").Select ' curseur sur A2
For compteur = 1 To 100
If ActiveCell.Offset(0, -1) = "" Then
ActiveCell = ""
Else
ActiveCell.FormulaR1C1 = "=IF(RC[-1]<>TODAY(),""KO"",""OK"")"
End If
ActiveCell.Offset(1, 0).Select
Next compteur
Range("I2").Select ' curseur sur A1
For compteur = 1 To 100
If ActiveCell.Offset(0, -2) = "" Then
ActiveCell = ""
Else
ActiveCell.FormulaR1C1 = "=IF(SUM(RC[2]:RC[14])=1,""OK"",IF(RC[-3]=1,""OK"",""KO""))"
End If
ActiveCell.Offset(1, 0).Select
Next compteur
Application.ScreenUpdating = True
End Sub

Bonne soirée
@+

 

[job75]

Re,

Job75 ton code ne fonctionne que si la date du jour est valide dans les cellules colonne G.

Oui parce qu'au post #1 vous avez utilisé le test If ActiveCell.Offset(0, -1) = Date Then

Puisque maintenant vous changez votre fusil d'épaule je fais de même :

Sub FormOKKO()
Application.ScreenUpdating = False
If FilterMode Then ShowAllData 'si la feuille est filtrée
On Error Resume Next 'si pas de SpecialCell
With Range("G2:G" & Rows.Count).SpecialCells(xlCellTypeConstants)
    Intersect(.EntireRow, [H:H]) = "=IF(RC[-1]<>TODAY(),""KO"",""OK"")"
    Intersect(.EntireRow, [I:I]) = "=IF(OR(SUM(RC[2]:RC[14])=1,RC[-3]=1),""OK"",""KO"")"
End With
Intersect([G:G].SpecialCells(xlCellTypeBlanks).EntireRow, [H:I]) = ""
End Sub

Edit : corrigé pour ne pas entrer de formules en H1 et I1...

Là c'est très rapide : 0,003 seconde.

A+

 

[counterbob]

Re,


Oui parce qu'au post #1 vous avez utilisé le test If ActiveCell.Offset(0, -1) = Date Then

Puisque maintenant vous changez votre fusil d'épaule je fais de même :

Sub FormOKKO()
Application.ScreenUpdating = False
If FilterMode Then ShowAllData 'si la feuille est filtrée
On Error Resume Next 'si pas de SpecialCell
With [G:G].SpecialCells(xlCellTypeConstants)
    Intersect(.EntireRow, [H:H]) = "=IF(RC[-1]<>TODAY(),""KO"",""OK"")"
    Intersect(.EntireRow, [I:I]) = "=IF(OR(SUM(RC[2]:RC[14])=1,RC[-3]=1),""OK"",""KO"")"
End With
Intersect([G:G].SpecialCells(xlCellTypeBlanks).EntireRow, [H:I]) = ""
End Sub

Là c'est très rapide : 0,003 seconde.

A+

C'est parfait
Merci
@+