Find Parameters in a User Defined Function

[ptownbro985]

This is a tricky one. Let's say I created a user defined function named "MyFunction" with three parameters "param1", "param2", and "param3". What I want to do is find the values passed to each parameter BUT... from another procedure!

Function:

Function MyFunction(param1, param2, param3)
   MyFunction = param1 & param2 & param3
End Function

Now, let's say I use the function in cell A1 as (used a weird result to illustrate problem):

=MyFunction(B1, C1, D1)

I started writing my other procedure as:

Sub MyProcedure()
   Dim MyBeg, MyEnd
   MyBeg = Instr(1, Range("A1").Formula, "MyFuction") + Len(Range("A1").Formula)
   MyEnd = Instr(MyBeg, Range("A1").Formula, ")")
   '... stopped when I realized this won't work (see below)
End Sub

The problem is that each paramater could be referring another functions making it difficult to find the last ")". As in:

=MyFunction(B1, Upper(C1 & lower(D1)), sum(E1, F1, G1))

Extra info for those interested:
What's the real reason why I want to do this? Well... long story, but in brief, what I'm ultimately trying to do is let the user overwrite "MyFunction" with a new value. Then using SheetSelectionChange and SheetChanged events at the application level, I want to save the new value to a back-end database using the parameters passed in the function they overwrote to determine which record to update. Go it all working (not as complicated as I may have made it sound), but just can't figure out how to get the parameters passed.

 

[ptownbro985]

Thanks Rick and Mike! Brilliant stuff. =) However, not working in all cases. Borrowing from pgc01's example, both would fail with something like this:

=MyFunction("text,text,text",UPPER(C5&LOWER(D5)),SUM(E5,F5,G5))

Both of your suggestions would return:

0 - "text
1 - text
2 - text"
3 - UPPER(C5&LOWER(D5))
4 - SUM(E5,F5,G5)

Wheres it should return:

0 - "text,text,text"
1 - UPPER(C5&LOWER(D5))
2 - SUM(E5,F5,G5)

 

[ptownbro985]

Thought it might be helpful to really explain what I'm ultimately trying to do and why I want this.

In my real project, this function is really querying a value from a back-end database. What I'm trying to do is allow the user to overwrite the function directly in the cell the function exists with a new value. Then what will happen is it will store that new value in the db and then restore the cell back to the original function. However, I need the parameters from the original function to determine which record to update in the db with that new value. Somewhat hard to explain in brief, but hopefully that makes sense. I'm doing this through the use of the SheetSelectionChange and SheetChange events and associated procedures. I'm able to allow them to overwrite the function, save the new value in a db, and restore the function. However, I can't get the parameters from the original function.

I've tried parsing and am now currently investigate maybe letting the function itself do the work.

Here's a strip down and basic version of my code (in reality I'm using application level handlers for the sheet events with a class module, dummy proof the code a bit, used diff variables, etc... but this is the jist).

I thought maybe when the user overwrites MyFunction, I could have MyFunction store the parameter results in Global variable first which I could then read from when I go to update the database. But that doesn't work because in the chain of events, the function is wiped out before I could read it. Now, I'm trying to see if I can get the MyFunction to store the results in global variables when the user selects the cell through the "SheetSelectionChange" change event.

Anyway, see code below.

'Module1 Module with MyFunction

Function MyFunction(param1, param2, param3)    
    'Added code here to query database as using param1, param2, and param3 to return a value through a recordset object named for example "rs"
    'Query could look like "Select Sum(myamt) from mytable where myfield1=param1 and myfield2=param2 and myfield3=param3"

    'Changed my original, but the function should really be return the query result.
    MyFunction = rs(0)
End Function

'ThisWorkbook Module

Public SavedAddress As String, SavedFormula As String

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
    If InStr(Target.Address, ":") = 0 Then
        If InStr(Target.Formula, "MyFunction") > 0 Then
            SavedAddress = Target.Address
            SavedFormula = Target.Formula
        End If
    End If
End Sub

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    If Not SavedAddress = "" Then
        If Target.Address = SavedAddress Then
            'Added code here to save new value from Target.Valueto database

            'Clear variable to prevent infinite loop (works better with app level sheet events vs workbook level)
            SavedAddress = ""

            'Restore original formula to requery database which will pick up original value and new value. Reset variable.
            Target.Formula = SavedFormula
            SavedFormula = ""
        End If
    End If
End Sub

 

[Jaafar Tribak]

How about tagging each range that has the UDF in it with a Name object .. Each range will have a tag (Name) attached to it .. the tag will store the range address plus the current values of the UDF parameters and it (the tag) will be refreshed each time the range is calculated

In order to do this, the tagging will have to be performed inside the UDF itself .. however we know that a UDF cannot and should not perform any actions on any excel objects (in this case creating a Name) .. Fortunatly, there is a workaround that I have used many times in the past to overcome this issue namely using the SetTimer API .. This comes in very handy in situations like this and should have no impact on performance because the timer runs once and is killed immediatly after 1 ms

Anyway, here is the code (along with your UDF) :
Place this in a standard module :

Private Declare Function SetTimer Lib "user32" _
        (ByVal hwnd As Long, _
        ByVal nIDEvent As Long, _
        ByVal uElapse As Long, _
        ByVal lpTimerFunc As Long) As Long
        
Private Declare Function KillTimer Lib "user32" _
        (ByVal hwnd As Long, _
        ByVal nIDEvent As Long) As Long
        
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
        pDest As Any, _
        pSource As Any, _
        ByVal dwLength As Long)

Private Declare Function lstrlenW Lib _
        "kernel32" (ByVal lpString As Long) As Long
        
        
Type UDF_PARAMS_VALUES
    Error As Boolean
    param1 As Variant
    param2 As Variant
    param3 As Variant
End Type

Function MyFunction(param1, param2, param3) As Variant
    Dim lPtr As Long
    Dim s As String
    
    s = Application.Caller.Address(False, False, xlA1, True) & _
    "|" & param1 & Chr(1) & param2 & Chr(1) & param3
    Dim l As Long
    l = InStr(1, s, "]")
    s = Replace(Mid(s, l + 1, Len(s) - l), "!", "±", , 1)
    lPtr = StrPtr(s)
    SetTimer Application.hwnd, lPtr, 1, AddressOf TagRange
    MyFunction = param1 & param2 & param3
End Function

Sub TagRange( _
            ByVal hwnd As Long, _
            ByVal uMsg As Long, _
            ByVal nIDEvent As Long, _
            ByVal dwTimer As Long _
            )
    Dim sTemp As String
    Dim lLen As Long
    Dim ar() As String
    
    On Error Resume Next
    KillTimer Application.hwnd, nIDEvent
    lLen = lstrlenW(nIDEvent) * 2
    sTemp = Space(lLen)
    CopyMemory ByVal sTemp, ByVal nIDEvent, lLen
    sTemp = Replace(sTemp, Chr(0), "")
    ar = Split(sTemp, "|")
    Names.Add Name:="¤" & ar(0), RefersTo:=ar(1) ', Visible:=False

End Sub

Function GetParams(ByVal Rng As Range, ByVal UDF As String) As UDF_PARAMS_VALUES
    Dim sTemp As String
    Dim l As Long
    Dim ar() As String
    
    On Error GoTo err_Handler
    If InStr(1, Rng.Formula, UDF) Then
        sTemp = Rng.Address(False, False, xlA1, True)
        l = InStr(1, sTemp, "]")
        sTemp = "¤" & Replace(Mid(sTemp, l + 1, Len(sTemp) - l), "!", "±")
        sTemp = Evaluate(Names(sTemp).Value)
        ar = Split(sTemp, Chr(1))
        GetParams.param1 = ar(0)
        GetParams.param2 = ar(1)
        GetParams.param3 = ar(2)
    Else
        GetParams.Error = True
    End If
    Exit Function
err_Handler:
    GetParams.Error = True
End Function

Usage code :
(assumes the UDF is in range a1 Sheet 1.. change these as required)

Sub Test()
    Dim tParams As UDF_PARAMS_VALUES
    
    tParams = GetParams(Rng:=Sheet1.Range("a1"), UDF:="MyFunction")
    If tParams.Error Then
        MsgBox "Make sure the range (""a1"") contains the 'MyFunction' " & vbLf & _
        "UDF and/or the arguments types are correct "
    Else
        MsgBox "current value of param1 is : " & tParams.param1
        MsgBox "current value of param2 is : " & tParams.param2
        MsgBox "current value of param3 is : " & tParams.param3
    End If
End Sub

If you want to quickly clean/delete all the names (tags) use the following:

Sub RemoveAllTagNames()
    Dim n As Name
    For Each n In Names
        If Left(n.Name, 1) = "¤" Then n.Delete
    Next
End Sub

I hope this works for you

 

[mikerickson]

One silly typo....
This works for me.
The Arguments function will return the text of the arguments of any formula.
e.g. B1 UPPER(C1&LOWER(D1)) SUM(E1,F1,G1)
or
"text" UPPER(C1 & LOWER(D1)) SUM(E1, F1, G1)

Using Evaluate will return the current value of those arguments

Sub Test()
    Dim Args As Variant
    Dim oneArg As Variant
    For Each oneArg In Arguments(Range("A2").Formula)
        MsgBox oneArg & " evaluates to" & vbCr & Evaluate(oneArg)
    Next oneArg
End Sub

Function Arguments(formulaString As String) As Variant
    Dim i As Long
    Dim startArg As Long, stopArg As Long
    Dim isQuoted As Boolean, parenCount As Long
    Dim Result() As String
    Dim outputIndex As Long
    If formulaString = vbNullString Then ReDim Result(-1 To -1): Arguments = Result: Exit Function
    ReDim Result(1 To Len(formulaString))
    startArg = 1 + InStr(1, formulaString, "(")
    For i = 1 + InStr(1, formulaString & "(", "(") To Len(formulaString) - 1
        If Mid(formulaString, i, 1) = Chr(34) Then
            isQuoted = Not isQuoted
        End If
        If Not isQuoted Then
            If Mid(formulaString, i, 1) = "(" Then parenCount = parenCount + 1
            If Mid(formulaString, i, 1) = ")" Then parenCount = parenCount - 1
            If Mid(formulaString, i, 1) = "," Then
                If parenCount = 0 Then
                    GoSub RecordArgument
                End If
            End If
        End If
    Next i
    'Exit Function
    GoSub RecordArgument
    ReDim Preserve Result(1 To outputIndex)
    Arguments = Result
    Exit Function
RecordArgument:
    outputIndex = outputIndex + 1
    Result(outputIndex) = Mid(formulaString, startArg, i - startArg)
    startArg = i + 1
    Return
End Function

 

[ptownbro985]

Very interesting!! Great idea. Thanks. I have to leave office and will take another look later to see if this will work for me.

Quick question in the meantime.

What do you mean by:

"... however we know that a UDF cannot and should not perform any actions on any excel objects (in this case creating a Name)"

Why not?

 

[Jaafar Tribak]

Hi ptownbro985,

I would use mikerickson's last solution because it works without the need to use API functions and is much simpler

 

[Rick Rothstein]

This will parse the sub-formulas that make up a formulas paramaters.

You need to add something similar to parenCount for braces (curly brackets) as your code errors for the following simplified example...

Formula in cell... =MyFunc({1,2,3})

Function code...

Function MyFunc(V As Variant)
  MyFunc = V(1)
End Function

 

[mikerickson]

You need to add something similar to parenCount for braces (curly brackets) as your code errors for the following simplified example...

Formula in cell... =MyFunc({1,2,3})

parenCount should be able to do double duty.

'...
If Not isQuoted Then
    Select Case Mid(formulaString, i, 1)
        Case "(", "{"
            parenCount = parenCount + 1
        Case ")", "}"
            parenCount = parenCount - 1
        Case ","
            If parenCount = 0 Then
                GoSub RecordArgument
            End If
    End Select
End If
'...

 

[pgc01]

Hi again

This is another option.

I identified 4 "problematic" expressions that could mess the separation of the parameters, because they allow commas

1 - Double quoted strings, like: "a,x,t"
2 - Single quoted strings, like: '2014,Q3'!D1:E3
3 - Arrays, like: {1,2,3}
4 - Parentheses, when they delimit the list of parameters of a function


I used this formula to test the code

=COUNTA('2014,Q3'!D1:E3,"a,x,t",{1,2,3},SUM('[Book2,(4{.xlsm]Sheet1'!$C$2,POWER(MAX(Z1:Z3),4)))

that should identify the 4 parameters

'2014,Q3'!D1:E3
"a,x,t"
{1,2,3}
SUM('[Book2,(4{.xlsm]Sheet1'!$C$2,POWER(MAX(Z1:Z3),4))

all of them with commas inside that should not throw off the code of the commas that really matter.

I wrote the formula in A2 and used to test:

Sub Test()
Dim sArrParams() As String

' gets an array with the parameters separated
sArrParams = ParamsSeparate(Range("A2").Formula)
MsgBox Join(sArrParams, vbNewLine)

End Sub

Set the reference to "Microsoft VBScript Regular Expressions 5.5".
The function:

Function ParamsSeparate(sFormula As String) As String()
Dim regex As RegExp
Dim sParams As String, s As String, sSplit() As String
Dim lPos As Long, lParam As Long

' assumes a formula type "=SomeFunction(List of parameters)" and gets the list of parameters
sParams = Left(sFormula, Len(sFormula) - 1) ' gets rid of the right parenthesis
sParams = Mid(sParams, InStr(sParams, "(") + 1) ' isolates the list of parameters

s = sParams
Set regex = New RegExp
regex.Pattern = "(""[^""]*?"")|('[^']*?')|(\([^()]*?\))|({[^{}]*?})"

Dim regexMatch As Match
While regex.Test(s)
    With regex.Execute(s)(0)
        Mid(s, .FirstIndex + 1, .Length) = String(.Length, " ")
    End With
Wend

sSplit = Split(s, ",")
For lParam = 0 To UBound(sSplit) - 1
    lPos = lPos + Len(sSplit(lParam)) + 1
    Mid(sParams, lPos, 1) = Chr(1)
Next lParam
ParamsSeparate = Split(sParams, Chr(1))
End Function