vba - 如何优化此 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分钟。
如果有人能为我指出如何优化此功能的正确方向，那就太好了。

编辑1:

HERE是工作簿链接。
两(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 毫秒
• COUNTA:7.8 毫秒
• 匹配:15 毫秒

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

我的解决方案是使用 VBA 宏而不是优化 UDF。另外，我没有使用 VLOOKUP，而是使用 Scripting.Dictionary 对象来存储所有序列号。根据How to optimize vlookup for high search count ? (alternatives to VLOOKUP)，使用 Scripting.Dictionary 查找速度快了 100 倍.

我在 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

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