Couleur de Cellule en fonction de la valeur

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

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

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

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