CODEWITHSUNDEEP
vbaexcel
G.Fox
G.Fox

Reputation: 3

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

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.

Upvotes: 0

Views: 1062

Answers (2)

Vegard
Vegard

Reputation: 4917

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

Upvotes: 0

Jaap
Jaap

Reputation: 3220

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)

Upvotes: 1

Related Questions