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