VBA Function 无效

Question

我不确定这是否可能，但我正在尝试在 VBA 中编写自定义 function 来解析数据，并将 output 选定的数据分成几行。 我希望 function 与列过滤器的工作方式相同，而是 function。 function 具有三个输入：第一列数据中的任何单元格、一个“键”（试图在第一列中匹配的值）和第二列中的任何单元格。 我不确定我做错了什么，但我不断收到“函数无效”的消息。 下面是我写的VBA代码：

Public Function PARSE(Col1 As Variant, key As Variant, Col2 As Variant)
    Dim i As Integer
    Set i = 1
    Dim ColumnRange As Integer
    Set ColumnRange = 1
    Dim Row As Integer
    Dim Col As Integer
    Dim Col22 As Integer
    Set Row = Col1.Row
    Set Col = Col1.Column
    Set Col22 = Col2.Column
    Dim K As Boolean
    Set K = False
    Do While K <> True
        Set Row = Row + 1
        Set K = IsEmpty(Range(Cells(Row, Col)).Value)
    Loop
    Dim Col1Value As Double
    For i = 1 To Row Step 1
        Set Col1Value = Cells(i, Col).Value
        If Col1Value = key Then
            Set ActiveCell.Value = Cells(i, Col22).Value
            ActiveCell.Offset(1, 0).Activate
        End If
    Next
End Function

我期待第 1 列中与键匹配的每个值，output 与匹配的同一行的第 2 列的值。 相反，我收到一条消息，说我的 function 无效。

Answer 1

UDF 返回数组

• 在 Microsoft 365 中（我没有）， C2中使用的公式 ( =SpillLookup(A2:A21,4,B2) ) 应该在单元格C2中返回K并将剩余结果溢出到C3:C7范围内。 欢迎任何反馈。
• 在旧版本的 Office 中，仅返回单元格C2中的K

Function

Function SpillLookup( _
    ByVal LookupColumnRange As Range, _
    ByVal StringMatch As String, _
    ByVal ValueColumnCell As Range) _
As Variant
    
    ' Write the values from the source columns to the source arrays.
    
    Dim lrg As Range: Set lrg = LookupColumnRange.Columns(1)
    Dim vrg As Range: Set vrg = lrg.EntireRow.Columns(ValueColumnCell.Column)
    
    Dim srCount As Long: srCount = lrg.Rows.Count ' = vrg.Rows.Count
    
    Dim lData() As Variant
    Dim vData() As Variant
    
    If srCount = 1 Then
        ReDim lData(1 To 1, 1 To 1): lData(1, 1) = lrg.Value
        ReDim vData(1 To 1, 1 To 1): vData(1, 1) = vrg.Value
    Else
        lData = lrg.Value
        vData = vrg.Value
    End If
    
    ' Return the looked-up values at the top of the Lookup array.
    
    Dim r As Long, drCount As Long
    
    For r = 1 To srCount
        If StrComp(CStr(lData(r, 1)), StringMatch, vbTextCompare) = 0 Then
            drCount = drCount + 1
            lData(drCount, 1) = vData(r, 1)
        End If
    Next r
    
    ' Return the looked-up values in the destination array.
    
    Dim dData() As Variant: ReDim dData(1 To drCount, 1 To 1)
    For r = 1 To drCount: dData(r, 1) = lData(r, 1): Next r
        
    ' Assign the destination array to the result.
    
    SpillLookup = dData

End Function

在 VBA 中的使用

Sub SpillLookupTEST()

     ' Read.
     
     ' Reference the lookup single-column range.
     Dim lrg As Range: Set lrg = Sheet1.Range("A2:A21")
     ' Reference any cell in the value column.
     Dim vCell As Range: Set vCell = Sheet1.Range("B1000") ' any cell in col. B
     ' Using the function, return the results in an array.
     Dim Data() As Variant: Data = SpillLookup(lrg, 4, vCell)
     
     ' Write.
     
     ' Reference the first destination cell.
     Dim dfCell As Range: Set dfCell = Sheet1.Range("F2")
     ' Reference the destination range.
     Dim drg As Range: Set drg = dfCell.Resize(UBound(Data, 1))
     ' Write the values from the destination array to the destination range.
     drg.Value = Data

End Sub