Vba 如何优化这个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

公共函数CLOOKUP（查找值，表数组作为范围，列索引作为长度_
rv_运算符、参考_值、可选范围_查找、_
可选返回（U索引）作为变量
暗NT_阵列，S_阵列
变暗，变暗
变暗行数等于长，行数小于等于长
使用Application.WorksheetFunction
如果列索引>0且列索引引用值
设置NT_数组=表_数组。调整大小（，1）
行计数=.CountA（NT\U数组）
设置S_数组=表_数组。调整大小（行数）
行小于=.Match（查找值，NT数组，0）
设置表\u数组=S\u数组。偏移量（少行，0）。调整大小（少行计数-少行）
出错时继续下一步
ORGLOOKUP=.VLookup（查找值、表数组、列索引、范围查找）
如果Err.number为0，则CLOOKUP=CVErr（xlErrNA）：退出功能
错误转到0
环
案例“>”
在ORGLOOKUP<参考值时执行
设置NT_数组=表_数组。调整大小（，1）
行计数=.CountA（NT\U数组）
设置S_数组=表_数组。调整大小（行数）
行小于=.Match（查找值，NT数组，0）
设置表\u数组=S\u数组。偏移量（少行，0）。调整大小（少行计数-少行）
出错时继续下一步
ORGLOOKUP=.VLookup（查找值、表数组、列索引、范围查找）
如果Err.number为0，则CLOOKUP=CVErr（xlErrNA）：退出功能
错误转到0
环
其他情况
CLOOKUP=CVErr（xlErrNA）
结束选择
选择Case True
Case IsMissing（返回索引）
CLOOKUP=ORGLOOKUP
其他情况
如果return_index我已经创建了一个解决方案，在我的笔记本电脑中大约需要40秒。我的笔记本电脑将公式复制到所有查找行大约需要7分钟

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


VLOOKUP:31毫秒
COUNTA:7.8毫秒
比赛时间：15毫秒

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

我的解决方案是使用VBA宏，而不是优化UDF。另外，我没有使用VLOOKUP，而是使用Scripting.Dictionary对象来存储所有序列号。使用脚本进行查找。字典速度比脚本快100倍

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

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

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

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

但是，在序列号为096364139508732708的第12779行中，参考日期为2013年1月9日，数据为2013年8月10日和2013年1月2日，您的自定义项生成的是2013年1月2日而不是#值！即使有一行的制造日期大于参考日期

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

以下是将电子表格和宏下载到的链接：。我打算只提供一个星期。宏代码如下：

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

选项显式
亚宏观1（）
'
'宏1宏
'
常量比较模式=“您能否提供一些相同的数据以及如何使用UDF。如果设置问题需要大量的工作，那么任何人都很难帮助您。我同意，L42，如果您可以上传任何测试工作簿，以便我们可以测试您的udf:），并且对于如何使用它以及它应该做什么也没有什么指导。请告诉我们您的数据是如何组织的？只有
表数组
的第一列被排序，或者列
列索引
也被排序？大家好，抱歉，这需要一些时间。我试图在不违反公司规则（法律）的情况下重新创建数据。我会尽快提供链接。感谢您花时间查看我的帖子。
如果10k数据可以提高到1分钟，那就太好了。
-事实上我不确定这是否可能，例如，您的UDF在我的笔记本电脑上计算了约10分钟，只是出于好奇，我测试了无条件vlookup和index/match，两者都是~4分钟（比您的UDF快2.5倍）。因此，在您的机器中，您的udf计算时间为5分钟，这意味着vlookup和索引/匹配应计算约2分钟。我认为不可能编写udf来计算条件vlookup比无条件vlookup更快。。我的意见是，您的UDF可以得到改进，但对于10k数据来说，一分钟也不能
，
太酷了！我不知道字典有那么快。我在我的系统上试用了你的代码和它的27秒2秒。虽然有不正确的结果，但这实际上指向了一个可能的方向。此外，这是我唯一的问题