# Colorizing Excel cells with a date range filter

In a table there is a number of column (chambre) and a number of row (alveole). If these matches in a list in an other sheet then it checks if it the date is between two dates on that second sheets. If it matches those 3 things, then it puts the sheet

My code works if I add DoEvents in every For, else Excel and VBA stops responding. But it takes around 5 minutes and I need to to this for 4 tables.

Is it my code that is not efficient? Do you have any ideas how to make it better?

Sub alveoles()

Application.ScreenUpdating = True
Dim moment As Date
'variables Photo
Dim four As Integer
Dim chambre As Integer
Dim alveole As Integer
Dim aaa As Integer
Dim ccc As Integer

'variables Gems
Dim ligne As Integer
Dim enfournement As Date
Dim defournement As Date

Dim lastrow As Integer

'set date and lastrow
moment = Worksheets("Photo").Range("O2").Value
lastrow = Worksheets("Gems").Range("A" & Rows.Count).End(xlUp).Row
four = 1
'Four1 1 row
For ligne = 2 To lastrow
DoEvents

For chambre = 1 To 38
DoEvents
For alveole = 1 To 6
DoEvents

enfournement = Worksheets("Gems").Range("D" & ligne).Value
defournement = Worksheets("Gems").Range("E" & ligne).Value

If four = Worksheets("Gems").Range("A" & ligne).Value And _
chambre = Worksheets("Gems").Range("B" & ligne).Value And _
alveole = Worksheets("Gems").Range("C" & ligne).Value And _
moment > enfournement And _
moment < defournement Then

aaa = alveole + 5
ccc = chambre + 2

Worksheets("Photo").Cells(aaa, ccc).Interior.ColorIndex = 1 'NOIR

End If
Next alveole
Next chambre
Next ligne

End Sub

• You should suspend calculation during the script and turn screen updating off. – Mr. Mascaro Jun 19 '15 at 20:28

Any time that you access each cell directly through the range object your performance is going to suffer.

Instead read the values into an array and then work on the data. For example the following excerpt:

For ligne = 2 To lastrow
...
enfournement = Worksheets("Gems").Range("D" & ligne).Value
defournement = Worksheets("Gems").Range("E" & ligne).Value


Should be replaced by:

Dim() data
data = Worksheets("Gems").Range("A2:F" & lastrow).Value
For ligne = 2 to lastrow
...
enfournement = data(ligne, 4)
defournement = data(ligne, 5)

• Hi luke ! I used your array idea and added a few things, deleted some sheets and now it works like a charm ! taking 10 secondes instead of 3+ mins. Thanks a lot ! – Karl-Éric Quirion Jun 22 '15 at 19:13

Let's think about what you're doing for a second.

For ligne = 2 To lastrow
DoEvents

For chambre = 1 To 38
DoEvents
For alveole = 1 To 6


6 * 38 = 228 iterations for every row. Wow. Yes. There's no wonder you had to give the OS time to operate.

All of this just to set the interior color of a cell. Which is a problem as well. What if the data changes? Well.... it's going to remain the same, forever as far as I can tell. There's nothing here to revert it. There's a better way. Use some conditional formatting to do this. No VBA needed. Just craft a formula that returns a True/False condition.

I can't claim this one is perfect or tested, but it should get you started.

=AND(GEMS!$A1 = 1, AND(GEMS!$B1 = COLUMN(), AND(GEMS!$C1 = ROW(), AND(GEMS!$D1 < PHOTO!$O$2, AND(GEMS!$E1 > PHOTO!$O\$2)))))

• Thanks for the answer ! Unfortunately i'm pretty sure I can't use this because the cells are already used by another formula... But I will certainly try something with it. Thanks again – Karl-Éric Quirion Jun 22 '15 at 13:14
• You mean you already have a conditional format? Just add a second one and set the priority. – RubberDuck Jun 22 '15 at 13:15

Not sure if I need to post this here. Thanks to @Luke cummings for the array idea. Here's the new code. It is not perfect and clean but it takes 10 seconds to run !

Sub alveoles()

Application.ScreenUpdating = True
Application.DisplayStatusBar = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False

Dim moment As Date
'variables Photo
Dim four As Integer
Dim chambre As Integer
Dim alveole As Integer
Dim aaa As Integer
Dim ccc As Integer

'variables Gems
Dim ligne As Integer
Dim enfournement As Date
Dim defournement As Date

Dim lastrow As Integer

Dim DataRange As Variant

'set date and lastrow
moment = Worksheets("Photo").Range("O2").Value
lastrow = Worksheets("Gems").Range("A" & Rows.Count).End(xlUp).Row
DataRange = Worksheets("Gems").Range("A1:E" & lastrow).Value

'mettre tout blanc
Worksheets("photo").Range("C6:AN11").Interior.ColorIndex = 2
Worksheets("photo").Range("C15:AN20").Interior.ColorIndex = 2
Worksheets("photo").Range("C27:u32").Interior.ColorIndex = 2
Worksheets("photo").Range("C36:u41").Interior.ColorIndex = 2

four = 1
'Four1  row1**********************************************************************************************
For ligne = 2 To lastrow
DoEvents

For chambre = 1 To 38
DoEvents
For alveole = 1 To 6
DoEvents

enfournement = DataRange(ligne, 4)
defournement = DataRange(ligne, 5)

If four = DataRange(ligne, 1) And _
chambre = DataRange(ligne, 2) And _
alveole = DataRange(ligne, 3) And _
moment > enfournement And _
moment < defournement Then

aaa = alveole + 5
ccc = chambre + 2

Worksheets("Photo").Cells(aaa, ccc).Interior.ColorIndex = 1 'NOIR

End If
Next alveole

Next chambre

Next ligne

• If you'd like to post a "this is the final code", it's polite to make it a community wiki. If you'd like another round of review, you should post a new question. =) – RubberDuck Jun 22 '15 at 21:13