HiveBrain v1.2.0
Get Started
← Back to all entries
snippetModerate

Colorizing Excel cells with a date range filter

Submitted by: @import:stackexchange-codereview··
0
Viewed 0 times
excelcolorizingwithrangedatecellsfilter

Problem

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

Solution

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)))))

Code Snippets

For ligne = 2 To lastrow
    DoEvents

    For chambre = 1 To 38
    DoEvents
        For alveole = 1 To 6
=AND(GEMS!$A1 = 1, AND(GEMS!$B1 = COLUMN(), AND(GEMS!$C1 = ROW(), AND(GEMS!$D1 < PHOTO!$O$2, AND(GEMS!$E1 > PHOTO!$O$2)))))

Context

StackExchange Code Review Q#94112, answer score: 10

Revisions (0)

No revisions yet.