Couleur de Cellule en fonction de la valeur

[bigbig]

Bonjour à tous,

J'ai une feuille remplis de nombre (0 ou 1).
Je souhaiterais mettre la couleur de fond des cellules contenant la valeur 0 en noir (cell.Interior.Color = 1).

Le problème est la rapidité de l'opération.
En effet, celà marche très bien mais comme j'ai parfois 50.000 cellules voir plus à vérifier, là ça met plusieurs secondes...

Après une 1ère solution avec la mise en forme conditionnelle (encore plus long + les raffraichissements)

Le code la plus rapide trouvé actuellement :

Application.ScreenUpdating = False
For Each cell In ActiveSheet.UsedRange
If cell.Value = 0 Then cell.Interior.Color = 1
Next
Application.ScreenUpdating = True

Apparament, ce n'est pas la lecture des valeurs des cellules qui est long mais le changement de couleur des cellules...

Merci de vos réponses, A+

 

[Hervé]

Re : Couleur de Cellule en fonction de la valeur

bonjour

tu peux etre essayer comme ceci, je ne suis pas sur que ca accelere bien le traitement, mais bon, on ne colore qu'une fois.

Dim cell As Range
Dim plage As Range

Application.ScreenUpdating = False

For Each cell In ActiveSheet.UsedRange
    If cell.Value = 0 Then
        If plage Is Nothing Then
            Set plage = cell
        Else
            Set plage = Union(plage, cell)
        End If
    End If
Next cell

plage.Interior.Color = 1
Application.ScreenUpdating = True

salut

 

[bigbig]

Re : Couleur de Cellule en fonction de la valeur

Merci pour cette solution.

Un 1er essais tel quel me donnait des délais 10 fois plus long (et j'ai pas attendu la fin)...
C'est assez logique puisque l'union est une opération rapide au début puis de plus en plus longue.
J'ai donc rajouter un compteur : TmpNB qui limite le nombre d'union (à 30 ici, valeur optimale testée)
Et là, j'arrive à être 3 fois plus rapide que ma 1ère méthode.

Mais encore un peu long pour de grands paquets de données :
250*20000 = 5 millions de cellules => 77 secondes sur mon vieux ordi.

Dim cell      As Range
Dim plage    As Range
Dim TmpNb  As Integer
Dim TmpPas As Integer

Application.ScreenUpdating = false

TmpNb = 0
TmpPas = 30
For Each cell In ActiveSheet.UsedRange
  If cell.Value = 0 Then
    If plage Is Nothing Then
      Set plage = cell
    Else
      Set plage = Union(plage, cell)
      TmpNb = TmpNb + 1
      If TmpNb >= TmpPas Then
        TmpNb = 0
        plage.Interior.Color = 1
        plage = Nothing
      End If
    End If
  End If
Next cell

plage.Interior.Color = 1

Application.ScreenUpdating = True

Une autre idée pour réduire encore le temp de calcul ?

Merci, A+

 

[Excel_lent]

Re : Couleur de Cellule en fonction de la valeur

[FONT=&quot]Salut à tous,

As-tu essayé une MFC directe et totale ?
Le problème qui peut surgir est celui du poids du fichier.
Les mises en forme de lignes et de colonnes entières font prendre de l'embonpoint ![/FONT]
[FONT=&quot] [/FONT]
[FONT=&quot]@+[/FONT]

 

[Hervé]

Re : Couleur de Cellule en fonction de la valeur

bonjour

Un 1er essais tel quel me donnait des délais 10 fois plus long (et j'ai pas attendu la fin)...

je suis surpris par cette remarque, meme si je ne pensais pas avoir trouvé le code le plus rapide, ca me semblait quand meme mieux.

le code que j'avais utilisé pour le test avec 50 000 cellules :

Dim cell As Range
Dim plage As Range
Dim temps

temps = Time
Cells.Clear
Range("a1:a10000") = 0
Range("b1:b5000") = 0
Range("d1:d15000") = 0
Range("e1:e20000") = 0

Application.ScreenUpdating = False

For Each cell In ActiveSheet.UsedRange
    If cell.Text = 0 Then
        If plage Is Nothing Then
            Set plage = cell
        Else
            Set plage = Union(plage, cell)
        End If
    End If
Next cell

plage.Interior.Color = 1
Application.ScreenUpdating = True
MsgBox Time - temps

désolé, mais j'ai pas d'autre solution simple, sinon apres c'est du bricolorigolo.

salut

 

[bigbig]

Re : Couleur de Cellule en fonction de la valeur

Pour Excel_lent :

J'ai essayer une MFC totale mais c'est un peu long quand il y a plusieurs millions de cellules concernées.
De plus, le refraichissement automatique est très génant avec les MFC. Or je ne peut pas le désactiver sans perturber d'autres trucs de mon fichier.
C'est par contre la solution la plus simple à mettre en oeuvre.

Pour Hervé :
Effectivement, ton exemple s'execute en quelques milisecondes.
Je suppose que c'est la façon de placer les 1 et les 0 qui change tout.
J'ai fait un essais en mettant des nombres entier aléatoirement dans 50000 cellules et le résultat est très très long.
L'union dois faire des regroupement de selection ce qui fait que quelques selection au final avec tes données.
Dans un cas plus aléatoire (plus proche de mes données) il n'y a que très peu de regroupement possible donc de nombreuses selections isolées.

Dim cell As Range
Dim plage As Range
Dim image(500, 100) As Integer
Dim temps

Randomize Timer

Cells.Clear
For TmpX = 1 To 100
For TmpY = 1 To 500
image(TmpY, TmpX) = Int(Rnd * 3)
Next TmpY
Next TmpX
Range("A1").Resize(500, 100).Value = image

temps = Time
Application.ScreenUpdating = False

For Each cell In ActiveSheet.UsedRange
If cell.Text = 0 Then
If plage Is Nothing Then
Set plage = cell
Else
Set plage = Union(plage, cell)
End If
End If
Next cell

plage.Interior.Color = 1
Application.ScreenUpdating = True
MsgBox Time - temps

A+

 

[Hervé]

Re : Couleur de Cellule en fonction de la valeur

re

un peu plus rapide.

on crée un tableau contenant les adresses des cellules à colorier (=0).

on doit pouvoir accelerer encore, en traitant les adresses par paquet de 30.

ce code s'execute chez moi en moins de 3 secondes.

Option Explicit
Option Base 1
Sub Bouton2_QuandClic()
Dim tablo
Dim tabloadr() As String
Dim i As Long
Dim j As Integer, cpt As Integer
Dim t As String
Dim image(500, 100) As Integer
Dim temps As Date
Dim TmpX As Integer
Dim TmpY As Integer

Randomize Timer

Cells.Clear

For TmpX = 1 To 100
    For TmpY = 1 To 500
        image(TmpY, TmpX) = Int(Rnd * 3)
    Next TmpY
Next TmpX

Range("A1").Resize(500, 100).Value = image

temps = Time
Application.ScreenUpdating = False

'*****************************************************
tablo = Range("a1").CurrentRegion

'creation d'un tableau d'adresse ne contenant que les cellules =0
For i = 1 To UBound(tablo)
    For j = 1 To UBound(tablo, 2)
        If tablo(i, j) = 0 Then
            cpt = cpt + 1
            ReDim Preserve tabloadr(1 To cpt)
            tabloadr(cpt) = Left(Cells(1, j).Address(0, 0), (Cells(1, j).Column < 27) + 2)
            tabloadr(cpt) = tabloadr(cpt) & i
        End If
    Next j
Next i

For i = 1 To UBound(tabloadr)
    Range(tabloadr(i)).Interior.Color = 0
Next i
'******************************************************
Application.ScreenUpdating = True
MsgBox Time - temps

End Sub

salut