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.
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.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.