Рефакторинг вложенных операторов «If»

Question

Вот некоторый код, который проходит через область в электронной таблице и выполняет код на основе условия, что исходные ячейки не содержат значение «(пустое» »). Код работает, но он очень неэффективен для запуска вложенных операторов if таким образом. Я попытался сделать его более эффективным в долгосрочной перспективе, но у меня нет идей.

Любые предложения?

Sub NestedIfStatement() 
Dim lastrow1 As Long 
Dim I As Integer, J As Integer, N As Integer, MaxPriority as Integer 
Dim Maxnumber as Range 
Dim WS1 As Worksheet, WS3 as Worksheet 
Dim WB As Workbook 

Set WB = ThisWorkbook 
Set WS1 = WB.Worksheets("Config") 
Set WS2 = WB.Worksheets("Data") 
Set WS3 = WB.Worksheets("Status Report") 

lastrow1 = WS1.Cells(Rows.Count, 1).End(xlUp).Row 
I = 1 
J = 1  
N = 3 
Set Maxnumber = WS1.Range("A" & I & ":A" & lastrow1) 
    MaxPriority = Application.Max(Maxnumber) 

For J = 1 To lastrow1 
    If WS1.Cells(J, 1) <= MaxPriority Then 
     If WS1.Cells(J, 6).Value <> "(blank)" Then 
      WS3.Cells(N, 7).Value = WS1.Cells(J, 6).Value 
     End If 
     If WS1.Cells(J, 5).Value <> "(blank)" Then 
      WS3.Cells(N, 6).Value = WS1.Cells(J, 5).Value 
     End If 
     If WS1.Cells(J, 4).Value <> "(blank)" Then 
      WS3.Cells(N, 4).Value = WS1.Cells(J, 4).Value 
     End If 
     If WS1.Cells(J, 3).Value <> "(blank)" Then 
      WS3.Cells(N, 3).Value = WS1.Cells(J, 3).Value 
     End If 
     If WS1.Cells(J, 2).Value <> "(blank)" Then 
      WS3.Cells(N, 2).Value = WS1.Cells(J, 2).Value 
     End If 
     N = N + 1 
    End If 
Next J 

End Sub 

Answer 1

Есть несколько отверстий в вашем объявлении переменной и присвоения, которое не может быть правильно расшифрованных к способу вариант массива, но, возможно, это поможет.

Sub Nested_UnIf_Statement() 
    Dim WS1 As Worksheet, WS3 As Worksheet, Maxnumber As Range 
    Dim lastrow1 As Long, I As Long, N As Long, MaxPriority As Long 
    Dim v As Long, vWS1s As Variant, vWS3BDs As Variant, vWS3FGs As Variant 

    Debug.Print Timer 
    Set WS1 = Worksheets("Sheet2") 
    Set WS3 = Worksheets("Sheet3") 

    I = 2 
    With WS1 
     lastrow1 = .Cells(Rows.Count, 1).End(xlUp).Row 
     Set Maxnumber = .Range("A" & I & ":A" & lastrow1) 
     MaxPriority = Application.Max(Maxnumber) 
     vWS1s = WS1.Range("A" & I & ":F" & lastrow1).Value2 
     ReDim vWS3BDs(1 To 3, 1 To 1) 
     ReDim vWS3FGs(1 To 2, 1 To 1) 
    End With 

    For v = LBound(vWS1s, 1) To UBound(vWS1s, 1) 
     If vWS1s(v, 1) <= MaxPriority Then 
      vWS3BDs(1, UBound(vWS3BDs, 2)) = Replace(vWS1s(v, 2), "(blank)", "") 
      vWS3BDs(2, UBound(vWS3BDs, 2)) = Replace(vWS1s(v, 3), "(blank)", "") 
      vWS3BDs(3, UBound(vWS3BDs, 2)) = Replace(vWS1s(v, 4), "(blank)", "") 
      vWS3FGs(1, UBound(vWS3FGs, 2)) = Replace(vWS1s(v, 5), "(blank)", "") 
      vWS3FGs(2, UBound(vWS3FGs, 2)) = Replace(vWS1s(v, 6), "(blank)", "") 
      ReDim Preserve vWS3BDs(LBound(vWS3BDs, 1) To UBound(vWS3BDs, 1), LBound(vWS3BDs, 2) To UBound(vWS3BDs, 2) + 1) 
      ReDim Preserve vWS3FGs(LBound(vWS3FGs, 1) To UBound(vWS3FGs, 1), LBound(vWS3FGs, 2) To UBound(vWS3FGs, 2) + 1) 
     End If 
    Next v 

    ReDim Preserve vWS3BDs(LBound(vWS3BDs, 1) To UBound(vWS3BDs, 1), LBound(vWS3BDs, 2) To UBound(vWS3BDs, 2) - 1) 
    ReDim Preserve vWS3FGs(LBound(vWS3FGs, 1) To UBound(vWS3FGs, 1), LBound(vWS3FGs, 2) To UBound(vWS3FGs, 2) - 1) 

    N = 3 
    WS3.Cells(N, 2).Resize(UBound(vWS3BDs, 2), UBound(vWS3BDs, 1)) = _ 
     Application.Transpose(vWS3BDs) 
    WS3.Cells(N, 2).Offset(0, UBound(vWS3BDs, 1) + 1).Resize(UBound(vWS3FGs, 2), UBound(vWS3FGs, 1)) = _ 
     Application.Transpose(vWS3FGs) 

    Debug.Print Timer 

End Sub 

В 5000 рядов рандомизированных данных, исходная процедура побежал в 00: 00: 01.10 секунд, пока этот один побежал в 00: 00: 00.13 секунд. Результаты были идентичными.

Answer 2

Вы пытались переключить режим расчета на ручной режим перед циклом, а затем переключить его обратно после цикла? То, что вы описываете, похоже на то, что при каждом изменении в каждом из WS3 есть множество вычислений. Также может быть отключено ScreenUpdating.

Так, что-то вроде этого:

Dim CalcMode As Long 
'... 
Application.ScreenUpdating = False 
CalcMode = Application.Calculation 
Application.Calculation = xlCalculationManual ' Change it to manual update 
For J = 1 To lastrow1 
    '... 
Next 
Application.Calculation = CalcMode ' Restore to what it was before 
Application.ScreenUpdating = True 

В качестве альтернативы, вы можете загрузить значения в WS1 в Array (Variant), а затем сделать вложенную If.

Другая проблема, которая может возникнуть у вас, - это не очистить содержимое WS3 до того, как цикл заполнит детали, которые делают нерелевантные данные.

---

EDIT (возможное решение)

Основываясь на том, что ваш код пытается достичь, вы могли бы просто использовать VBA для назначения Формулы для ассоциированных ячеек - нет петель!

Предполагая, что есть заголовок в строке 2 в WS3, полученный FormulaR1C1 для столбцов B, C, D является:
=IF(Config!R[-2]C<>"(blank)",Config!R[-2]C,"")
и столбцов F, G является:
=IF(Config!R[-2]C[-1]<>"(blank)",Config!R[-2]C[-1],"")

Чтобы сделать формулы более общий , Я положил '<S1>' в строку const. lastrow3 - это в основном последняя строка, которая нуждается в этих формулах в WS3, и зависит от количества строк, используемых в столбце A WS1.

Просьба сделать различие и отправить сообщение с помощью этого кода, нам все интересно узнать об эффективности с данными реального мира.

Option Explicit 

Sub NestedIfStatement() 
    Const Formula_FG = "=IF('<S1>'!R[-2]C[-1]<>""(blank)"",'<S1>'!R[-2]C[-1],"""")" 
    Const Formula_BCD = "=IF('<S1>'!R[-2]C<>""(blank)"",'<S1>'!R[-2]C,"""")" 

    Dim CalcMode As Long, sFormula As String 
    Dim lastrow3 As Long 
    Dim WS1 As Worksheet 

    Application.ScreenUpdating = False 
    CalcMode = Application.Calculation 
    Application.Calculation = xlCalculationManual 

    With ThisWorkbook 
     Set WS1 = .Worksheets("Config") 
     lastrow3 = WS1.Cells(Rows.Count, 1).End(xlUp).Row + 2 ' Offset from row 1 to 3 (N) 
     With .Worksheets("Status Report") 
      .UsedRange.Offset(1, 0).ClearContents ' Remove old data below the header row 
      sFormula = Replace(Formula_BCD, "<S1>", WS1.Name) 
      .Range("B3:D" & lastrow3).FormulaR1C1 = sFormula 
      sFormula = Replace(Formula_FG, "<S1>", WS1.Name) 
      .Range("F3:G" & lastrow3).FormulaR1C1 = sFormula 
     End With 
     Set WS1 = Nothing 
    End With 

    Application.Calculation = CalcMode 
    Application.ScreenUpdating = True 

End Sub