Добавить формулу в ячейки при выборе

Question

Я пытаюсь создать код, который будет переключать ячейки в строке между введенной пользователем переменной или одной, вычисленной из таблицы поиска. У меня есть тот, который работает в основном, но он работает очень медленно! So:

• Какие-либо предложения по этому поводу работают быстрее?

• Как я могу заставить его смотреть только на ячейки, где изменяется значение в столбце (с выпадающим списком автоматической/ручной проверки данных)?

Я удалил формулу из нижеследующего, поскольку они немного длинны.

Код:

Application.ScreenUpdating = False 
Application.AutoCorrect.AutoFillFormulasInLists = False 

'define variables 
Dim Tbl As Range 
Dim RngAuto As Range 
Dim TblRows As Integer 
Dim i As Integer 
Dim cell As Range 

Set Tbl = Range(ActiveSheet.ListObjects(1)) 

TblRows = Tbl.Rows.Count 

'MsgBox ("Warning, proceeding will clear all data for this row!") 

For i = 1 To TblRows 
    If Tbl(i, 8).Text = "Aut" Then 'if set to automatic add formlars to cells 
     Tbl(i, 20).FormulaR1C1 = "Formula Here" 
     Tbl(i, 20).Interior.ColorIndex = 37 

     Tbl(i, 21).FormulaR1C1 = "Formula Here" 
     Tbl(i, 21).Interior.ColorIndex = 37 

     Tbl(i, 22).FormulaR1C1 = "Formula Here" 
     Tbl(i, 22).Interior.ColorIndex = 37 

     Tbl(i, 25).FormulaR1C1 = "Formula Here" 
     Tbl(i, 25).Interior.ColorIndex = 37 

     Tbl(i, 30).FormulaR1C1 = "Formula Here" 
     Tbl(i, 30).Interior.ColorIndex = 37 

     Tbl(i, 31).FormulaR1C1 = "Formula Here" 
     Tbl(i, 31).Interior.ColorIndex = 37 

     Tbl(i, 32).FormulaR1C1 = "Formula Here" 
     Tbl(i, 32).Interior.ColorIndex = 37 

     Tbl(i, 33).FormulaR1C1 = "Formula Here" 
     Tbl(i, 33).Interior.ColorIndex = 37 

     Tbl(i, 34).FormulaR1C1 = "Formula Here" 
     Tbl(i, 34).Interior.ColorIndex = 37 

    Else 
     Set RngAuto = Application.Union(Tbl(i, 20), Tbl(i, 21), Tbl(i, 22), Tbl(i, 25), Tbl(i, 30), Tbl(i, 31), Tbl(i, 32), Tbl(i, 33), Tbl(i, 34)) 

     With RngAuto 
      .Interior.ColorIndex = 0 
      .Select 
     End With 

     For Each cell In Selection 
      cell.Value = cell.Value 
     Next cell 

    End If 

Next i 

Application.ScreenUpdating = True 

End Sub 

Заранее спасибо.

Answer 1

Я надеюсь, что следующее немного быстрее.

Public Sub AutoUpdate() 

Dim strSearchRange As String 
Dim strFirstFound As String 
Dim intLastRow As Integer 
Dim intColumns As Integer 
Dim varFound As Variant 
Dim RngAuto As Range 
Dim cell As Range 
Dim Tbl As Range 


With Application 
    .EnableEvents = False 
    .ScreenUpdating = False 
    .Calculation = xlCalculationManual 
    .AutoCorrect.AutoFillFormulasInLists = False 
End With 

strSearchRange = Range(ActiveSheet.ListObjects(1)).Offset(, 7).Resize(, 1).Address 
intLastRow = ActiveSheet.ListObjects(1).ListRows.Count + 1 

'MsgBox ("Warning, proceeding will clear all data for this row!") 

For Each intColumn In Array(20, 21, 22, 25, 30, 31, 32, 33, 34) 
    With ActiveSheet 
     .Range(.Cells(2, intColumn), .Cells(intLastRow, intColumn)).Interior.ColorIndex = 0 
     .Range(.Cells(2, intColumn), .Cells(intLastRow, intColumn)).Value2 = .Range(.Cells(2, intColumn), .Cells(intLastRow, intColumn)).Value2 
    End With 
Next intColumn 

With Worksheets(1).Range(strSearchRange) 
    Set varFound = .Find("Aut", LookIn:=xlValues) 
    If Not varFound Is Nothing Then 
     strFirstFound = varFound.Address 
     Do 
      ActiveSheet.Range(.Cells(varFound.Row, 20), .Cells(varFound.Row, 22)).FormulaR1C1 = "Formula Here" 
      ActiveSheet.Range(.Cells(varFound.Row, 20), .Cells(varFound.Row, 22)).Interior.ColorIndex = 37 
      ActiveSheet.Range(.Cells(varFound.Row, 25), .Cells(varFound.Row, 25)).FormulaR1C1 = "Formula Here" 
      ActiveSheet.Range(.Cells(varFound.Row, 25), .Cells(varFound.Row, 25)).Interior.ColorIndex = 37 
      ActiveSheet.Range(.Cells(varFound.Row, 30), .Cells(varFound.Row, 34)).FormulaR1C1 = "Formula Here" 
      ActiveSheet.Range(.Cells(varFound.Row, 30), .Cells(varFound.Row, 34)).Interior.ColorIndex = 37 
      Set varFound = .FindNext(varFound) 
     Loop While Not varFound Is Nothing And varFound.Address <> strFirstFound 
    End If 
End With 

With Application 
    .Calculation = xlCalculationAutomatic 
    .ScreenUpdating = True 
    .EnableEvents = True 
End With 

End Sub 

Обратите внимание, что я не смог полностью его протестировать. Поэтому может потребоваться небольшая настройка.

То, что я включил (1), выключил предлагаемые ScreenUpdating и EnableEvents, но также и Calculation. (2) Использование функции .Find вместо прокрутки по всем строкам. (3) Используйте .value2 вместо .value. (4) Формулы изменения массы, группируя их вместе.