Как оптимизировать этот UDF

Question

Как оптимизировать этот UDF

У меня есть это UDF который я использую для поиска дат и возврата значений на основе условия.
В основном только два (2) условия, либо < или же > Дата.
Кроме того, я просто использую встроенные функции Excel и просто добавил некоторые условия.

Public Function CLOOKUP(lookup_value, table_array As Range, column_index As Long, _
                        rv_operator, reference_value, Optional range_lookup, _
                        Optional return_index) As Variant

Dim NT_array, S_array
Dim ORGLOOKUP, REFLOOKUP
Dim row_count As Long, row_less As Long

With Application.WorksheetFunction
    If column_index > 0 And column_index <= table_array.Columns.Count Then

        On Error Resume Next
        ORGLOOKUP = .VLookup(lookup_value, table_array, column_index, range_lookup)
        If Err.number <> 0 Then CLOOKUP = CVErr(xlErrNA): Exit Function
        On Error GoTo 0

        Select Case rv_operator
        Case "<"
            Do While ORGLOOKUP > reference_value
                Set NT_array = table_array.Resize(, 1)
                row_count = .CountA(NT_array)
                Set S_array = table_array.Resize(row_count)
                row_less = .Match(lookup_value, NT_array, 0)
                Set table_array = S_array.Offset(row_less, 0).Resize(row_count - row_less)

                On Error Resume Next
                ORGLOOKUP = .VLookup(lookup_value, table_array, column_index, range_lookup)
                If Err.number <> 0 Then CLOOKUP = CVErr(xlErrNA): Exit Function
                On Error GoTo 0
            Loop
        Case ">"
            Do While ORGLOOKUP < reference_value
                Set NT_array = table_array.Resize(, 1)
                row_count = .CountA(NT_array)
                Set S_array = table_array.Resize(row_count)
                row_less = .Match(lookup_value, NT_array, 0)
                Set table_array = S_array.Offset(row_less, 0).Resize(row_count - row_less)

                On Error Resume Next
                ORGLOOKUP = .VLookup(lookup_value, table_array, column_index, range_lookup)
                If Err.number <> 0 Then CLOOKUP = CVErr(xlErrNA): Exit Function
                On Error GoTo 0
            Loop
        Case Else
            CLOOKUP = CVErr(xlErrNA)
        End Select

        Select Case True
        Case IsMissing(return_index)
            CLOOKUP = ORGLOOKUP
        Case Else
            If return_index <= table_array.Columns.Count Then
                REFLOOKUP = .VLookup(lookup_value, table_array, return_index, range_lookup)
                CLOOKUP = REFLOOKUP
            Else
                CLOOKUP = CVErr(xlErrNA)
            End If
        End Select
    Else
        CLOOKUP = CVErr(xlErrNA)
    End If
End With

End Function

Он отлично работает, но я хочу немного его оптимизировать, чтобы улучшить скорость вычислений.
Обычно я использую это для поиска 10 тыс. Строк в файле Excel с 600 тыс. Или более строк.
Это занимает 5~8 минут в отсортированных данных.
Если кто-то может указать мне правильное направление, как оптимизировать эту функцию, это было бы здорово.

Edit1:

ЗДЕСЬ ссылка на рабочую книгу.
Два (2) листа, источник данных и данные для поиска, само собой разумеется.
Я также включил функцию в WB.
Я использовал эту функцию, чтобы заполнить значения в Таблице данных для поиска в столбце " Дата изготовления" и просто оставить первую ячейку с фактической формулой, чтобы избежать проблем при ее открытии.
Для тех, кто не заинтересован, вот синтаксис о том, как использовать функцию:

lookup_value - что вы ищете
table_array - где вы смотрите
column_index - столбец, из которого вы хотите получить информацию на основе вашего lookup_value
rv_operator - определяет, является ли возвращаемое значение меньше или больше reference_value
reference_value - где сравнивается возвращаемое значение
range_lookup - точное или приблизительное совпадение
return_index - альтернативный индекс столбца, на тот случай, если вам нужно вернуть данные помимо того, что получают от column_index

Помните, что я использую это, чтобы получить DATES Итак column_index всегда содержит дату, а также reference_value,
Вот причина, почему существует return_index поскольку мне может понадобиться восстановить информацию, которая подпадает под условия, но на самом деле не заинтересована в датах.

Например, в моей рабочей тетради мне нужно указать дату изготовления серийного номера. 096364139403422056 но оно должно быть меньше эталонного значения 1/4/2014,
Этот серийный номер встречается несколько раз, поэтому мне нужно максимально приблизиться к эталонному значению.
Результат должен быть 11/15/2013 используя функцию: =CLOOKUP(B2,'Source Data'!A:B,2,"<",A2,0)Надеюсь, что объяснение выше поможет вам, ребята.

Кстати, это также может быть достигнуто с помощью Array Formulas,
Я только что сделал эту формулу в пользу других пользователей, которые не очень хорошо разбираются в AF's,

5

excel vba excel-vba excel-2010

Источник

user2685412 19 мар '14 в 07:30

1 ответ

Решение

Другие вопросы по тегам excel vba excel-vba excel-2010

user807417 04 апр '14 в 05:40 2014-04-04 05:40 · Accepted Answer · 2014-04-04 05:40

Я создал решение, которое занимает около 40 секунд на моем ноутбуке. Мой ноутбук занимает около 7 минут, чтобы скопировать формулу во все строки поиска.

Когда я измерил различные узкие места в оригинальном UDF, я обнаружил, что VLOOKUP очень дорогой. Пример использования строки, близкой к нижней:

VLOOKUP: 31 мс
СЧЕТ: 7,8 мс
Совпадение: 15 мс

Поскольку вы потенциально можете вызывать вышеупомянутые функции несколько раз (при наличии дубликата), это еще больше времени.

Мое решение - использовать макрос VBA вместо оптимизации UDF. Кроме того, вместо использования VLOOKUP я использую объект Scripting.Dictionary для хранения всех серийных номеров. Поиск с использованием Scripting.Dictionary выполняется в 100 раз быстрее. Как оптимизировать vlookup для большого количества запросов? (альтернативы VLOOKUP).

Я протестировал его на Office 2010, работающем под Windows 7. Загрузка всех серийных номеров в Словарь занимает около 37 секунд, в то время как поиск и заполнение столбца C занимает около 3 секунд! Поэтому совсем не проблема иметь больше строк в таблице поиска!

Если макрос создает жалобы при создании Scripting.Dictionary, вам может потребоваться добавить ссылку на Microsoft Scripting Runtime (подробности см. Выше).

Когда я сравнил результат с вашей формулой UDF, я обнаружил некоторую несогласованность, которая может быть связана с ошибкой в вашем коде UDF. Например:

В строке 12739, серийный номер 096364139401213204, ссылочной датой является 13.01.2013, данные - 03.01.2013 и 23.04.2013, но результат #VALUE! Таким образом, похоже, что ЛЮБЫЕ из данных БОЛЬШЕ, чем контрольная дата, вы хотите, чтобы результат был # ЗНАЧЕНИЕ!
ОДНАКО, в строке 12779, серийный номер 096364139508732708, ссылочная дата - 01.01.2013, данные - 10/10/2013 и 1/2/2013, ваш UDF выдает 1/2/2013 вместо #VALUE! даже если есть строка с Mfg date больше, чем контрольная дата.

Я не знаю, какое поведение вы хотите, поэтому я предполагаю, что вы хотите отобразить # ЗНАЧЕНИЕ! когда ЛЮБОЙ из данных больше, чем контрольная дата. Если вы хотите изменить поведение, пожалуйста, дайте мне знать или обновите код самостоятельно (я поместил обильный комментарий в коде).

Вот ссылка для загрузки электронной таблицы и макроса по адресу: https://www.dropbox.com/s/djqvu0a4a6h5a06/Sample%20Workbook%20Optimized.xlsm. Я собираюсь сделать его доступным только на 1 неделю. Макрос код ниже:

Option Explicit
Sub Macro1()
'
' Macro1 Macro
'
Const COMPARISONMODE = "<"
Const SOURCESHEETNAME = "Source Data"
Const LOOKUPSHEETNAME = "Data for Lookup"

Dim oSource
Set oSource = CreateObject("Scripting.Dictionary")

Dim starttime, endtime, totalindex


'BUILD THE INDEX in oSource
'Column A = serial number
'Column B = mfg date
'Column C = extra data
'Each item contains a comma separated list of row numbers
starttime = Timer

Sheets(SOURCESHEETNAME).Activate
Dim rownum, serialno, mfgdate
rownum = 2
Do
  serialno = Cells(rownum, 1)
  If Not IsError(serialno) Then
    serialno = CStr(serialno)
    If serialno = "" Then Exit Do
    If oSource.Exists(serialno) Then
      oSource(serialno) = oSource(serialno) & "," & rownum
    Else
      oSource.Add serialno, CStr(rownum)
    End If
  End If
  rownum = rownum + 1
Loop

endtime = Timer

totalindex = endtime - starttime

starttime = Timer

'DO THE LOOKUP
'NOTE: Assume that there are no #VALUE! in columns A and B of the lookup table
Dim rownumlist, sourcerownum, aryRownumlist, refdate, closestmfgdate, closestextradata, j
Sheets(LOOKUPSHEETNAME).Activate
rownum = 2
Do
  refdate = CDate(Cells(rownum, 1))
  serialno = Cells(rownum, 2)
  If serialno = "" Then Exit Do
  If Not oSource.Exists(serialno) Then
    Cells(rownum, 3) = CVErr(xlErrNA)
    GoTo ContinueLoop
  End If
  aryRownumlist = Split(oSource(serialno), ",")
  closestmfgdate = ""
  closestextradata = ""
  'Find the closest manufacturing date to the reference date out of all matches
  For j = LBound(aryRownumlist) To UBound(aryRownumlist)
    sourcerownum = CLng(aryRownumlist(j))
    mfgdate = Sheets(SOURCESHEETNAME).Cells(sourcerownum, 2)
    If IsError(mfgdate) Then Exit For  'if any of the date in the matches is not valid, output N/A
    mfgdate = CDate(mfgdate)
    'Exclude depending on COMPARISONMODE
    'must be less than the reference date if COMPARISONMODE = "<", otherwise it has to be greater than
    'If comparison failed for ANY of the matches, we will output N/A
    'If you want the failed comparison match to be excluded but still output a date, instead of doing
    '   Exit For, you can do Goto ContinueFor.  Example:
    '      If mfgdate >= refdate Then Goto ContinueFor
    'QUESTION: What to do if it is equal?  Assume that we will output N/A as well
    If COMPARISONMODE = "<" Then
      If mfgdate >= refdate Then closestmfgdate = "": Exit For
    Else
      If mfgdate <= refdate Then closestmfgdate = "": Exit For
    End If
    'Now check whether it is closer to refdate
    If closestmfgdate = "" Then
        closestmfgdate = mfgdate
        closestextradata = Sheets(SOURCESHEETNAME).Cells(sourcerownum, 3)
    ElseIf Abs(DateDiff("d", closestmfgdate, refdate)) > Abs(DateDiff("d", mfgdate, refdate)) Then
        closestmfgdate = mfgdate
        closestextradata = Sheets(SOURCESHEETNAME).Cells(sourcerownum, 3)
    End If
ContinueFor:
  Next
  If closestmfgdate = "" Then
    Cells(rownum, 3) = CVErr(xlErrNA)
    Cells(rownum, 4) = ""
  Else
    Cells(rownum, 3) = closestmfgdate
    Cells(rownum, 4) = closestextradata
  End If
ContinueLoop:
  rownum = rownum + 1
Loop


endtime = Timer

MsgBox "Indexing time=" & totalindex & " seconds; lookup time=" & (endtime - starttime) & " seconds"

End Sub

Если вы найдете вышеуказанное решение удовлетворительным, присудите награду или, по крайней мере, примите решение. Благодарю.