Speeding up VBA Macro with multiple 'For' and 'if' statements

Question

This macro takes 2+ minutes to run. What are the best methods to optimize the macro?

Sub Time_Color(z, k)

Application.DisplayAlerts = False

For Each cell In Sheet1.Range("C" & z & ":" & "LZ" & z)
    If cell.Value <> "x" Then
           If cell.Value < Sheet3.Range("D" & k) Then
              cell.Interior.ColorIndex = 37
              cell.Offset(1, 0).Value = Sheet4.Range("D" & k).Value & "_" & Sheet4.Cells(k, 5).Value
           End If

        For j = 5 To 1000 Step 2
         If cell.Value > Sheet3.Cells(k, j).Value And cell.Value < Sheet3.Cells(k, j + 1).Value Then
         cell.Interior.ColorIndex = 37
         cell.Offset(1, 0).Value = Sheet4.Cells(k, j + 1).Value & "_" & Sheet4.Cells(k, j + 2).Value
        End If
       Next j

       For j = 4 To 1000 Step 2
       If cell.Value >= Sheet3.Cells(k, j).Value And cell.Value <= Sheet3.Cells(k, j + 1).Value Then
       cell.Interior.ColorIndex = 43
       cell.Offset(1, 0).Value = Sheet4.Cells(k, j).Value & "_" & Sheet4.Cells(k, j + 1).Value
       End If
       Next j
End If
Next cell
Application.DisplayAlerts = True

End Sub

I am running this macro for 24 different combinations of z,k.

Since you're comparing the exact same values in both loops, you only need one of them. — justkrys, Dec 21 '15 at 21:45
Turn off ScreenUpdating and Calculation while running. Calculation should be reset before your Sub ends (ScreenUpdating will reset itself) — Tim Williams, Dec 21 '15 at 21:48
Do as little cell manipulations as possible in the loop but try to collect the cells which need to altered in a range and manipulate them in one go outside the loop. — SilentRevolution, Dec 21 '15 at 22:24
Are your values in Sheet3 rows always ascending? If so you don't have to loop, could use a `WorksheetFunction.Match` to find the location instead of stepping j up to 1000. — tigeravatar, Dec 21 '15 at 23:19
@TimWilliams you should turn your comment into an answer, so G.Fox can mark it as correct. — Jaap, Dec 22 '15 at 07:49
Is the end loop number in `For j = 4/5 to 1000` just a large number to make sure you always cover the number of columns you have or are there always 996 columns with data to check against on sheet 3 and retrieve on sheet4? — SilentRevolution, Dec 22 '15 at 13:00
I am trying to make a schedule which can be updated to reflect the current order of jobs at each work station for the week. I have an "Update Time" macro set up so that it first goes through and marks any past days/ times with an 'x' in the cell as well as any cell the user marks for nonscheduled hours, i.e. pto/ holidays. From here the "update time" assigns values in empty cells of 0.5 increments which are the remaining available "work hours" left in the week. I then have sheet 3 broken down by setup and run time in hours for each work center. Time_Color is match the colors for each. — G.Fox, Dec 22 '15 at 15:12

Jaap · Accepted Answer · 2015-12-22T07:49:01.190

1

Try caching as much data as possible, for instance Sheet3.Range("D" & k) is constant throughout this function.

Every instance of the inner most loop will query that cell. If you put it at the beginning of this function, it will be looked up once and then used for the remainder of the function.

Edit: In the comments on this question is - I think - a better answer by Tim Williams, which is specific to VBA:

Turn off ScreenUpdating and Calculation while running. Calculation should be reset before your Sub ends (ScreenUpdating will reset itself)

edited Dec 22 '15 at 07:49

answered Dec 21 '15 at 21:50

Jaap

3,081
2
29
50

I try doing that by 'Dim r as Range' and then 'r= Range("D" & k)' but I get the Run-time error- 91: Object variable or With block variable not set. Sorry if this is a dumb question, I am new to all of this. – G.Fox Dec 21 '15 at 22:20
1

When setting object variables you use Set, so `Set r = Range("D" & k)` – Tim Williams Dec 22 '15 at 07:11

score 0 · Answer 2 · edited May 23 '17 at 12:07

I'm not entirely sure what you are trying to accomplish, but it seems that your loop iterates over a large range to find the last-most instance of a cell that satisfies one of the two given criteria (your two loops).

If that is the goal, why not start from the back? Depending on how your sheet looks, this is potentially a lot faster!

I also made some other changes. Let me know how it works.

Take care to also include the function at the bottom (heisted from this answer), or substitute it for your function of choice.

Sub Time_Color(z, k)
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False

    Dim loopVal, loopVal2, loopVal3 As Variant
    Dim setOdd, setEven, OddEven As Boolean

    Dim compVal, compVal2, compVal3 As Variant
    compVal = Sheet3.Range("D" & k).Value
    compVal2 = Sheet4.Range("D" & k).Value
    compVal3 = Sheet4.Cells(k, 5).Value


    For Each cell In Sheet1.Range("C" & z & ":" & "LZ" & z)
        If cell.Value <> "x" Then
            If cell.Value < compVal Then
                cell.Interior.ColorIndex = 37
                cell.Offset(1, 0).Value = compVal2 & "_" & compVal3
            End If

            For j = 1000 To 4 Step -1
                loopVal = Sheet3.Cells(k, j).Value
                loopVal2 = Sheet3.Cells(k, j + 1).Value
                loopVal3 = Sheet4.Cells(k, j + 1).Value
                OddEven = OddOrEven(j)

                If OddEven = True Then
                    If cell.Value > loopVal And cell.Value < loopVal2 Then
                        cell.Interior.ColorIndex = 37
                        cell.Offset(1, 0).Value = loopVal3 & "_" & Sheet4.Cells(k, j + 2).Value
                        setOdd = True
                    End If
                Else
                    If cell.Value >= loopVal And cell.Value <= loopVal2 Then
                        cell.Interior.ColorIndex = 43
                        cell.Offset(1, 0).Value = Sheet4.Cells(k, j).Value & "_" & loopVal3
                        setEven = True
                    End If
                End If

                If setEven = True And setOdd = True Then Exit For
            Next j
        End If
    Next cell
    Application.DisplayAlerts = True
End Sub


Function OddOrEven(a As Integer) As Boolean ' Returns TRUE if a is an odd number
    If a - (2 * (Fix(a / 2))) <> 0 Then OddOrEven = True
End Function

I am trying to make a schedule which can be updated to reflect the current order of jobs at each work station for the week. I have an "Update Time" macro set up so that it first goes through and marks any past days/ times with an 'x' in the cell as well as any cell the user marks for nonscheduled hours, i.e. pto/ holidays. From here the "update time" assigns values in empty cells of 0.5 increments which are the remaining available "work hours" left in the week. I then have sheet 3 broken down by setup and run time in hours for each work center. Time_Color is match the colors for each. — G.Fox, Dec 22 '15 at 15:34

Speeding up VBA Macro with multiple 'For' and 'if' statements

2 Answers2