Оптимизируйте формулу Excel, которая использует большие массивы

Question

Я использовал приведенную ниже формулу excel.

=INDEX(TABL,SMALL(IF(COUNTIF(H2,$A$1:$A$325779)*COUNTIF(I2,"<="&$B$1:$B$325779),ROW(TABL)-MIN(ROW(TABL))+1),1),3) 

Где "TABL", таблица, является A1: E325779 и является источником моего поиска массива.

Указанная формула является точным требованием, но занимает много времени, чтобы обновить excel для 400 000+ клеток, содержащих эту формулу.

Можно ли это оптимизировать? Или это можно приравнять к более быстрому макросу?

Принимает 1 секунду, чтобы обновить 1 ячейку !!! Это очень долгое время, чтобы обновить все ячейки 400K +!

Снимок экрана рабочего листа, как показано ниже.

Я основывал свою программу на Мартин Карлссона. обрабатывает 100 записей за 30 секунд. можно ли улучшить?

Sub subFindValue() 
    Application.ScreenUpdating = False 
    Application.DisplayStatusBar = False 
    Application.Calculation = xlCalculationManual 
    Application.EnableEvents = False 

    Cells(2, 12) = Format(DateTime.Now, "yyyy-MM-dd hh:mm:ss") 

    Dim varRow As Variant 
    Dim varRowMain As Variant 
    Dim lookupTable As Variant 
    Dim lookupValueTable As Variant 

    lookupValueTable = Range("G2:J309011").Value 
    lookupTable = Range("A2:D325779").Value 

    varRowMain = 1 
    varRow = 1 

    Do Until varRowMain = 309011 
     Do Until varRow = 325779 
      If lookupTable(varRow, 1) = lookupValueTable(varRowMain, 1) And lookupTable(varRow, 2) >= lookupValueTable(varRowMain, 2) Then 
       lookupValueTable(varRowMain, 3) = lookupTable(varRow, 3) 
       lookupValueTable(varRowMain, 4) = lookupTable(varRow, 4) 
       Exit Do 
      End If 
      varRow = varRow + 1 
     Loop 

     If IsEmpty(lookupValueTable(varRowMain, 3)) Then 
      lookupValueTable(varRowMain, 3) = "NA_OX" 
      lookupValueTable(varRowMain, 4) = "NA_OY" 
     End If 

     varRowMain = varRowMain + 1 
     varRow = 1 
    Loop 
    Range("G2:J309011").Value = lookupValueTable 

    Cells(3, 12) = Format(DateTime.Now, "yyyy-MM-dd hh:mm:ss") 

    Application.ScreenUpdating = True 
    Application.DisplayStatusBar = True 
    Application.Calculation = xlCalculationAutomatic 
    Application.EnableEvents = True 
End Sub 

Answer 1

Это должно работать и быть намного быстрее, чем любое решение VBA, который потребует зацикливание каждой строки до тех пор, как вы можете сортировать даты в колонке B По убыванию:

Введите следующую формулу массива (вместо Enter используйте Ctrl + Shift + Enter

=INDEX($C$1:$C$15,MATCH(G2,IF($A$1:$A$15=F2,$B$1:$B$15),-1)) 

Вы должны закончить с чем-то вроде:

Пояснение:

IF($A$1:$A$15=F2,$B$1:$B$15) 

строит массив значений, равных строк в столбце В, где Тест слово в том же столбце строки А.

MATCH(G2,IF($A$1:$A$15=F2,$B$1:$B$15),-1) 

Это с использованием Массив, построенный из оператора Id, чтобы найти наименьшее значение, большее или равное значению Look up из тестовых данных.

=INDEX($C$1:$C$15,MATCH(G2,IF($A$1:$A$15=F2,$B$1:$B$15),-1)) 

После того, как все это вместе «ИНДЕКС» возвращает значение в колонке С, которое в том же положении, что и согласованного значения.

UPDATE: Если вы ищете какие tigeravatar возвращает Ответ, то здесь другая функция VBA, который возвращает все значения:

Sub GetValues() 

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

Dim strMetalName As String: strMetalName = [E3] 
Dim dbMinimumValue As Double: dbMinimumValue = [F3] 

Range("G3:G" & Rows.Count).ClearContents 

With Range("TABL") 
    .AutoFilter Field:=1, Criteria1:=strMetalName 
    .AutoFilter Field:=2, Criteria1:=">=" & dbMinimumValue, Operator:=xlAnd 
    Range("C2", [C2].End(xlDown)).Copy [G3] 
    .AutoFilter 
End With 

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

Для меня его взял 5-7 минут, чтобы бежать в то время как это заняло 1,5 секунды, когда мой первый ответ возвращает единственную строку, содержащую ближайший результат совпадения, этот sub вернет ВСЕ значения больше или равно.

Answer 2

Это то, что вам нужно?

Sub subFindValue() 
    'Speed up 
    Application.ScreenUpdating = False 
    Application.DisplayStatusBar = False 
    Application.Calculation = xlCalculationManual 
    Application.EnableEvents = False 

    Dim strNamedValue As String: strNamedValue = Range("E3") 
    Dim curHigherThanValue As Currency: curHigherThanValue = Range("F3") 
    Dim varRow As Variant 

    varRow = 1 
    Do Until IsEmpty(Cells(varRow, 1)) 
     If Cells(varRow, 1) = strNamedValue And Cells(varRow, 2) > curHigherThanValue Then 
      Range("G3") = Cells(varRow, 3) 
      Exit Do 
     End If 
     varRow = varRow + 1 
     Loop 

    'Slow down 
    Application.ScreenUpdating = True 
    Application.DisplayStatusBar = True 
    Application.Calculation = xlCalculationAutomatic 
    Application.EnableEvents = True 
    End Sub 

Answer 3

Если данные отсортированы по колонке 2 в колонке 1, то функция SpeedTools Filter.Ifs будет намного быстрее, чем ваша формула (по крайней мере в 50 раз быстрее)

=FILTER.IFS(2,$A$1:$C$325779,3,1,E3,2,">" & F3) 

Отказ от ответственности: Я являюсь автором SpeedTools, который является коммерческим продуктом Excel addin.
Вы можете скачать полную версию от:
http://www.decisionmodels.com/FastExcelV3SpeedTools.htm

Answer 4

Вам может понадобиться отрегулировать, где выход идет (предполагается, что результаты должны быть выведены в ячейке G3 и вниз), но это должно работать довольно быстро:

Sub subFindValue() 

    Dim rngFound As Range 
    Dim arrResults() As Variant 
    Dim varFind As Variant 
    Dim dCompare As Double 
    Dim ResultIndex As Long 
    Dim strFirst As String 

    varFind = Range("E3").Text 
    dCompare = Range("F3").Value2 

    Range("G3:G" & Rows.Count).ClearContents 

    With Range("TABL").Resize(, 1) 
     Set rngFound = .Find(varFind, .Cells(.Cells.Count), xlValues, xlWhole) 
     If Not rngFound Is Nothing Then 
      ReDim arrResults(1 To WorksheetFunction.CountIf(.Cells, varFind), 1 To 1) 
      strFirst = rngFound.Address 
      Do 
       If rngFound.Offset(, 1).Value > dCompare Then 
        ResultIndex = ResultIndex + 1 
        arrResults(ResultIndex, 1) = rngFound.Offset(, 2).Text 
       End If 
       Set rngFound = .Find(varFind, rngFound, xlValues, xlWhole) 
      Loop While rngFound.Address <> strFirst 
     End If 
    End With 

    If ResultIndex > 0 Then Range("G3").Resize(ResultIndex).Value = arrResults 

End Sub