简体   繁体   中英

VBA Function isn't valid

I'm not sure if this is possible, but I am trying to write a custom function in VBA to parse through data and output selected data into several rows. I want the function to be the same as how a column filter works, but a function instead. The function has three inputs: any cell in the first column of data, a "key" (the value that is trying to be matched in the first column), and any cell in the second column. I'm not sure what I am doing wrong, but I keep getting the message of "Function is invalid." Below is the VBA code I wrote:

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

I was expecting for every value in column 1 that matches the key, output the value of column 2 of the same row with the match. Instead I got a message that says my function is invalid.

UDF Returning an Array

  • In Microsoft 365 (I don't have it), the formula used in C2 ( =SpillLookup(A2:A21,4,B2) ) should return K in cell C2 and spill the remaining results in the range C3:C7 . Any feedback is most welcome.
  • In older versions of Office, only the K in cell C2 is returned.

在此处输入图像描述

The 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

Usage in 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

The technical post webpages of this site follow the CC BY-SA 4.0 protocol. If you need to reprint, please indicate the site URL or the original address.Any question please contact:yoyou2525@163.com.

 
粤ICP备18138465号  © 2020-2024 STACKOOM.COM