Question

我写了一个VBA宏，我想提高性能，因为该宏需要很长时间才能运行。

我认为运行效果会受到

的影响

For Each rCell In .Range("O3:O" & Range("O" & Rows.Count).End(xlUp).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

Answer 1

尝试一下：

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

我认为您要根据同一行中的M，N和L列的值设置O列的颜色。

我得出这个结论的原因是因为在您的代码中，列O单元格的颜色仅取决于最后一行中的值，因为内部循环的每次迭代都会覆盖同一单元格

Answer 2

这是您要尝试的吗？摘录：

    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

提高循环内if else条件的性能

2 个答案: