8
\$\begingroup\$

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
\$\endgroup\$
  • 2
    \$\begingroup\$ You should suspend calculation during the script and turn screen updating off. \$\endgroup\$ – Mr. Mascaro Jun 19 '15 at 20:28
6
\$\begingroup\$

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)
\$\endgroup\$
  • \$\begingroup\$ 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 ! \$\endgroup\$ – Karl-Éric Quirion Jun 22 '15 at 19:13
10
\$\begingroup\$

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)))))
\$\endgroup\$
  • \$\begingroup\$ 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 \$\endgroup\$ – Karl-Éric Quirion Jun 22 '15 at 13:14
  • \$\begingroup\$ You mean you already have a conditional format? Just add a second one and set the priority. \$\endgroup\$ – RubberDuck Jun 22 '15 at 13:15
1
\$\begingroup\$

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
\$\endgroup\$
  • \$\begingroup\$ 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. =) \$\endgroup\$ – RubberDuck Jun 22 '15 at 21:13

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.