CODEWITHSUNDEEP
excelvba
brice
brice

Reputation: 5

Improve the performance of a if else condition inside a loop

I wrote a VBA macro & I want to improve the performance because the macro takes ages to run.

I think that the running performance is impacted by the

For Each rCell In .Range("O3:O" & Range("O" & Rows.Count).End(xlUp).Row) which intend to limit the loop up to the first empty row.

Sub E_Product_Density_Check()

Dim ws As Worksheet

Set Vws = ThisWorkbook.Sheets("Variables")

Sheets("Sheet1").Select

Application.ScreenUpdating = False
For Each ws In ActiveWorkbook.Worksheets
If ws.Name <> "Variables" Then

 Application.DecimalSeparator = ","

ws.Activate

With ActiveSheet
        For Each rCell In .Range("O3:O" & Range("O" & Rows.Count).End(xlUp).Row)
        For Each iCell In .Range("N3:N" & Range("N" & Rows.Count).End(xlUp).Row)
        For Each xCell In .Range("M3:M" & Range("M" & Rows.Count).End(xlUp).Row)
        For Each yCell In .Range("L3:L" & Range("L" & Rows.Count).End(xlUp).Row)

            If (rCell.Value / ((iCell.Value * xCell.Value * yCell.Value) / 1000000)) <= Application.WorksheetFunction.VLookup(ActiveSheet.Name, Vws.Range("A1:E10"), 5, False) Then
                rCell.Interior.Color = vbYellow
            Else
                rCell.Interior.Color = vbWhite
            End If
        Next yCell
        Next xCell
        Next iCell
        Next rCell
    End With
    End If
    Next ws
End Sub

Upvotes: 0

Views: 79

Answers (2)

John Alexiou
John Alexiou

Reputation: 29274

Try this:

Sub E_Product_Density_Check2()
    Dim ws As Worksheet, Vws As Worksheet
    Set Vws = ThisWorkbook.Sheets("Variables")

    Sheets("Sheet1").Select
    ' Application.ScreenUpdating = False  (no need for this)
    Application.DecimalSeparator = ","

    Dim target As Variant
    Dim r_O As Range, r_N As Range, r_M As Range, r_L As Range
    Dim n As Long
    Dim i As Long

    For Each ws In ActiveWorkbook.Worksheets
        If ws.Name <> "Variables" Then
            ' For the target value for each worksheet
            target = Application.WorksheetFunction.VLookup(ws.Name, Vws.Range("A1:E10"), 5, False)
            ' ws.Activate  (this was slow)

            'Find the number of cells in column O, and assume the same number exists in N, M & L.
            n = ws.Range(ws.Range("O3"), ws.Range("O3").End(xlDown)).Rows.Count
            Set r_O = ws.Range("O3")
            Set r_N = ws.Range("N3")
            Set r_M = ws.Range("M3")
            Set r_L = ws.Range("L3")

            For i = 1 To n
            ' Go down the column O
                If (r_O.Cells(i, 1).Value / ((r_N.Cells(i, 1).Value * r_M.Cells(i, 1).Value * r_L.Cells(i, 1).Value) / 1000000)) < target Then
                    r_O.Cells(i, 1).Interior.Color = vbYellow
                Else
                    r_O.Cells(i, 1).Interior.Color = vbWhite
                End If
            Next i
        End If
    Next ws
End Sub

I think what you are trying to do is set the color of column O based on the values of columns M, N & L in the same row.

The reason I came to this conclusion is because with your code the color of column O cell is determined only by the values in the last rows only since each iteration of the inner loops overwrites the same cell.

Upvotes: 1

Cyril
Cyril

Reputation: 6829

Is this what you're trying to do? Snippit:

    Dim r as long, lr as long, myvalue as double 'r is row to iterate, lr is last row, myvalue = your vlookup
    'skipping the other code to get down to the loop
    With ActiveSheet
        myvalue = Application.WorksheetFunction.VLookup(ActiveSheet.Name, Vws.Range("A1:E10"), 5, False) 'shoudl only need to find this once
        lr = .cells(.rows.count,"O").end(xlup).row
        For r = 2 to lr 'starting on 2 because 1 is probably headers
            If (.Cells(r,"O").Value / ((.Cells(r,"N").Value * .Cells(r,"M").Value * .Cells(r,"L").Value) / 1000000)) <= myvalue Then
                .Cells(r,"O").Interior.Color = vbYellow
            Else
                .Cells(r,"O").Interior.Color = vbWhite
            End If
        Next r
    End With

Upvotes: 0

Related Questions