Optimiser une boucle For each .. next

Version imprimable

Bonjour,

Je dois remettre un onglet comportant un nombre important de cellule en fonction de leur couleur. Il ne s'agit pas d'une plage fixe malheureusement.

Le code que j'ai trouvé prend énormément de temps :
Code:

1 2 3 4 5 6 7 8 Sheets("E3_Affectation_CI&PD").Select For Each Cellule In Range("g8:BZ329") If ActiveCell.Interior.ColorIndex = 36 Then ActiveCell.Value = "" End If Next End Sub
Auriez-vous une autre astuce pour accélérer le traitement?

J'ai pensé à mettre une autre condition : si la valeur de la cellule est vide. Mais la macro ne fait plus rien...
Code:

1 2 3 4 5 6 7 8 9 Sheets("E3_Affectation_CI&PD").Select For Each Cellule In Range("g8:BZ329") If ActiveCell.Interior.ColorIndex = 36 And ActiveCell.Value <> "" Then ActiveCell.Value = "" End If Next End Sub
Merci par avance pour votre aide

Bonjour,
déjà, au départ, ton code devrait être

Code:

1
2
3
4
5
6
7
8
Dim Cellule As Range
With Sheets("E3_Affectation_CI&PD")
   For Each Cellule In .Range("g8:BZ329")
     If Cellule.Interior.ColorIndex = 36 Then
       Cellule.Value = ""
     End If
  Next Cellule
End With

Pour la rapidité, je vais regarder, sans garantie

24/05/2016, 18h19
borisp

Merci!

en respectant tes limites, essayes ce code maxi 1 seconde

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
Sub couleurs()
Dim Cellule As Range, x As Long, y As Long
Dim Tb(), tb1
With Sheets("E3_Affectation_CI&PD")
  tb1 = .Range("g8:BZ329")
  ReDim Tb(1 To UBound(tb1, 1), 1 To UBound(tb1, 2))
  For x = 7 To 72
    For y = 8 To 329
      Tb(y - 7, x - 6) = .Cells(y, x).Interior.ColorIndex
    Next y
  Next x
  For x = 1 To UBound(tb1, 2)
    For y = 1 To UBound(tb1, 1)
      If Tb(y, x) = 36 Then tb1(y, x) = ""
    Next y
  Next x
  .Range("G8").Resize(UBound(tb1, 1), UBound(tb1, 2)) = tb1
End With
End Sub

dis-moi quoi car vite fait

Edit :code modifié (un peu plus logique)

24/05/2016, 19h06
borisp

Au top ça marche impec merci infiniment!
25/05/2016, 19h48
borisp

En fait cela marche bien mais la fonction efface les formules de mon tableau sans les recopier. Les formules sont copiées en dur...
Est-ce que tu aurais une parade casefayere? Merci beaucoup
26/05/2016, 12h52
casefayere

Bonjour, je ne savais pas qu'il y avais des formules donc, il faudrait passer par une boucle pour remplir "tbl",comme "tb", conclusion temps de traitement légèrement allongé, mais la parade consiste à ne prendre dans "'tbl" que la plage sans les formules, pour ça il me faudrait des indications supplémentaires, (ou sont les formules, etc.)
26/05/2016, 13h53
borisp

LE problème est qu'il y a des formules à plusieurs endroits assez variables...mais avec des couleurs identifiées.
Est-ce qu'il est possible de garder les formules en fonction de certaines couleurs ?

Il s'agit des couleurs 15 et 25.

Merci beaucoup
26/05/2016, 13h57
casefayere

là, tu compliques le travail, peux-tu envoyer un fichier bidon, je regarderai sans promesse de résultat, à moins que quelqu'un plus aguerri puisse te donner une bonne piste
26/05/2016, 15h10
borisp

1 pièce(s) jointe(s)

Le voici merci.

J'ai laissé juste l'onglet en question. La macro correspondante est "effacer" ou Module 3 dans le code.

Les formules ont sautées mais en gros ce sont les celulles bleues foncées et grises

Merci ça serait vraiment top!!

1 pièce(s) jointe(s)

Si tu gardes toutes les formules, la solution est plus simple que ce que j'aurais pu croire

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
Option Explicit'je me suis permi
Sub Effacer()
Dim Cellule As Range, x As Long, y As Long
Dim Tb(), Tb1, Dcel As Long
 
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'msgbox d'alerte
 
Dim msgValue
msgValue = MsgBox("Attention, vous allez effacer toutes les données saisies", vbOKCancel + vbExclamation, "ATTENTION !")
If msgValue = vbCancel Then
  Exit Sub
End If
 
'Remise à zéro de l'onglet E3_Affectation_CI&PD
 
With Sheets("E3_Affectation_CI&PD")
Dcel = .Range("F" & .Rows.Count).End(xlUp).Row
  Tb1 = .Range("G8:AG" & Dcel).Formula
  ReDim Tb(1 To UBound(Tb1, 1), 1 To UBound(Tb1, 2))
  For x = 7 To 33
    For y = 8 To Dcel
      Tb(y - 7, x - 6) = .Cells(y, x).Interior.ColorIndex
    Next y
  Next x
  For x = 1 To UBound(Tb1, 2)
    For y = 1 To UBound(Tb1, 1)
      If Tb(y, x) = 36 Then Tb1(y, x) = ""
    Next y
  Next x
 .Range("G8").Resize(UBound(Tb1, 1), UBound(Tb1, 2)) = Tb1
End With
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
 
End Sub

essayes et dis-moi
Pièce jointe 210927

30/05/2016, 11h43
borisp

Bonjour et merci beaucoup pour ta réponse, je n'ai pu essayer que ce matin.

Le code me renvoi une erreur sur la ligne :

Code:

Dcel = .Range("F" & .rows.Count).End(xlUp).row

Il indique une "invalid or unqualified reference" sur .rows.

C'est une erreur de déclaration de variable?

Merci encore pour ton aide précieuse
30/05/2016, 11h50
casefayere

Code:

Dcel = .Range("F" & .rows.Count).End(xlUp).row

la syntaxe est correcte d'autant qu'avant on spécifie

Code:

With Sheets("E3_Affectation_CI&PD")

de plus Dcel est bien déclaré en long, vérifie le nom de ta feuille et ce que contient la colonne F, j'avais vérifié mon code donc quelque-chose a du changer entre temps
30/05/2016, 11h53
borisp

Yes c'est bon au temps pour moi j'avais effacé cette ligne par erreur :

Code:

With Sheets("E3_Affectation_CI&PD")

Je te remercie vivement pour tout :)