如何优化此UDF

Question

我有这个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

它工作正常但我想稍微优化它以提高计算速度.
通常我使用它在600k或更多行的excel文件中查找10k行.
排序数据需要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.

Answer 1

我在笔记本电脑上创建了一个大约需要 40 秒的解决方案。我的笔记本电脑大约需要 7 分钟才能将公式复制到所有查找行。

当我测量原始UDF中的各种瓶颈时，我发现VLOOKUP非常昂贵。使用靠近底部的行的示例：

• VLOOKUP：31 毫秒
• 计数：7.8 毫秒
• 匹配：15 毫秒

由于您可能会多次调用上述函数（当存在重复时），因此更加耗时。

我的解决方案是使用 VBA 宏而不是优化 UDF。另外，我没有使用 VLOOKUP，而是使用 Scripting.Dictionary 对象来存储所有序列号。根据如何优化 vlookup 以实现高搜索计数？使用 Scripting.Dictionary 的查找速度快了 100 倍。（VLOOKUP 的替代方案）。

我在 Windows 7 上运行的 Office 2010 上进行了测试。将所有序列号加载到字典中大约需要 37 秒，而查找和填充 C 列大约需要 3 秒！因此，查找工作表中包含更多行根本不是问题！

如果宏在创建 Scripting.Dictionary 时出现错误，您可能需要添加对 Microsoft Scripting Runtime 的引用（有关详细信息，请参阅上面的链接）。

当我将结果与您的 UDF 公式进行比较时，我发现一些不一致，这可能是由于您的 UDF 代码中的错误造成的。例如：

1. 第12739行，序列号096364139401213204，参考日期为1/13/2013，数据为1/3/2013和4/23/2013，但结果是#VALUE！因此，如果任何数据大于参考日期，您希望结果为#VALUE！

2. 然而，在第 12779 行，序列号 096364139508732708，参考日期为 1/9/2013，数据为 8/10/2013 和 1/2/2013，您的 UDF 生成 1/2/2013 而不是 #VALUE！即使有一行的制造日期大于参考日期。

我不知道您想要什么行为，所以我假设您想显示#VALUE！当任何数据大于参考日期时。如果您想改变这种行为，请告诉我，或者自己更新代码（我在代码中添加了大量注释）。

以下是下载电子表格和宏的链接：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

如果您认为上述解决方案令人满意，请授予赏金或至少接受该解决方案。谢谢。