Application.run with more than 30 arguments - excel

I am using Excel VBA. Does anyone know about a way to overcome the argument length limit of Application.Run()? (Or please suggest other function that can do the same job.)
Specific to my situation some of my constraints are:
I need to specify the called function as a string
The function is within a standard module
It is a function, the return value is needed, so Call() will not work.
In any case, I do not want the parameter list of the called function to be changed (e.g. to variant array or ParamArray) since I have written some other functionalities which depend on the function declaration.
EDIT: In response to some of the comments below I can provide a simplified version of my project here (could be off the original question though). In fact the whole design is established and running smooth except for the 30-arg constrain.
The very ultimate goal is to enable the following spreadsheet function which can be called like =mySpreadSheetFn("calledFn", "para1=abc", "para2=2002", ...). This will invoke the function calledFn() whose declaration may be:
Function calledFn(Optional para1 As String = "P1", _
Optional para2 As Integer = 202, _
Optional para3 As Boolean = True)
and the default argument will be replaced accordingly as specified in the ParamArray in the mySpreadSheetFn() call. Similarly there will be calledFn2() etc which an end user can use. So, there has to be an Application.Run() inside mySpreadSheetFn() .
And here are the function definitions:
Type paramInfo
Val As Variant
dataType As String 'can be Enum but let's forget it for this purpose
End Type
Function mySpreadSheetFunction(fnName As String, ParamArray otherParams())
Dim fnParams As Scripting.Dictionary
' getFnDefaultParams(fn): return the defaults and data types of fn's params
' as a Dictionary. Each item is of type paramInfo (see above)
Set fnParams = getFnParams(fnName)
' For each specified arg check whether it exists for the function.
' If so, replaces the default value with the input value.
' If not exist, then just ignore it
' The problem is really not with this part so just know
' we have all the parameters resolved after the for-loop
For i = LBound(otherParams) To UBound(otherParams)
Dim myKey As String
myKey = Split(otherParams(i), "=")(0)
If fnParams.Exists(myKey) Then
' parseParam() converts the input string into required data type
fnParams(myKey).Val = parseParam(Split(otherParams(i), "=", 2)(1), _
fnParams(myKey).DataType _
)
End If
Next
' Here is the issue since the call cannot go beyond 30 args
Dim lb As Integer: lb = LBound(fnParams)
Select Case UBound(fnParams) - LBound(fnParams) + 1
Case 1: Application.Run fnName, fnParams(lb).Val
Case 2: Application.Run fnName, fnParams(lb).Val, fnParams(lb + 1).Val
' Omitted, goes until Case 30
' What to do with Case 31??
End Select
' Some other operations for each call
End Function
' An example of function that can be called by the above mySpreadSheetFn()
Function calledFn(Optional para1 As String = "P1", _
Optional para2 As Integer = 202, _
Optional para3 As Boolean = True)
' needs to return value
calledFn = para1 & para2 * 1000
End Function
There is hardly any room to change the front-end since this is how the user interface is desired.
Any thoughts?

Probably a bit late, but if you transfer the method to a class, everything becomes much easier:
Class "c1"
Public Sub IHaveTooManyArguments(ParamArray params())
Debug.Print "Refactor me!"
End Sub
Module "Main"
Public Sub CallIHaveTooManyArguments(fnName As String, ParamArray params())
Dim o as new c1
CallByName o, fnName, VbMethod, params
End Sub

Pack several arguments into an array. Or pack several arguments into some sort of data document, like an Xml file/string, or a JSON file/string, or an ordinary text file.

If you're determined to call a procedure with more that 30 parameters via Application.Run, you'll need a trampoline procedure in order to match its function signature. Make a second prodecure that takes the parameters in an array (or some other package), and then pass that to a second procedure that calls the one with too many parameters:
Sub Test()
Dim args As Variant
args = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, _
17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, _
31, 32)
Application.Run "ToManyArgsTrampoline", "fnName", args
End Sub
Sub ToManyArgsTrampoline(fnName As String, args() As Variant)
If UBound(args) = 31 Then
IHaveTooManyArguments fnName, args(0), args(1), args(2), args(3), args(4), args(5), _
args(6), args(7), args(8), args(9), args(10), args(11), _
args(12), args(13), args(14), args(15), args(16), args(17), _
args(18), args(19), args(20), args(21), args(22), args(23), _
args(24), args(25), args(26), args(27), args(28), args(29), _
args(30), args(31)
End If
End Sub
Sub IHaveTooManyArguments(fnName As String, ParamArray otherparams())
Debug.Print "Refactor me!"
End Sub

Related

Edit table function only works unpredictably

what im trying to do:
change table data if value is like the passed criteria
code:
Sub editTableData(tableName As String, rw As Integer, col As Integer, str As String)
Sheet1.ListObjects(tableName).Range(rw, col).value = str
End Sub
Sub EDITTABLEDATAONOTHERPAGE()
Call editTableData("statement", 20, 6, "Why did this work?")
End Sub
result:
03/19/2020, WAL-MART SUPERCENTER, 67.07, blank, blank, "Why did this work?"
but when called here:
Function categorize(criteria As String) As Double
Dim statement As listobject, statementNames As Range, statementCategory As Range, statementCredit As Range, name As Range
Set statement = Sheet1.ListObjects("statement")
Set statementNames = Sheet1.ListObjects("statement").ListColumns("Name").DataBodyRange
Set statementCategory = Sheet1.ListObjects("statement").ListColumns("Category").DataBodyRange
Set statementCredit = Sheet1.ListObjects("statement").ListColumns("Credit").DataBodyRange
'---this is the part that matters:--------------------------------
For Each name In statementNames
If name.value Like criteria + "*" Then
Call editTableData(statement.name, name.row, statementCategory.column, statement.name)
categorize = categorize + statementCredit(name.row, statementCredit.column).value
End If
Next
End Function
it gets to the method, it passes editTableData("statement", 20, 6, "statement") as String, int, int, String respectively (so the same data) but it just stops working and i dont know why.
anything enlightening would be nice, here is the table that i am using this table to call the formula as well:
a picture of the table
Update/amendment:
Here is the debug photos:
CALLING THE METHOD
in the method (reference locals window for values):
in the method
and when I press F8 Again this time, it crashed...
No error message, none of the other cells above or below were changed so its just not working at all. if it were an index problem that would be easy enough to fix

VBA VLookup Method not working for both numbers and strings

I have a workbook full of product codes and names. Contained within a form are various text boxes where a user can enter a code and its corresponding label will update with the name found in the workbook. Each text box runs the following sub when changed
Private Sub FindItem(x As Long)
Dim Name As Variant
Name = Application.VLookup(AddStockForm.Controls("Code" & x).Text, Sheet1.Range("B:C"), 2, False)
If IsError(Name) Then
AddStockForm.Controls("Name" & x).Caption = "Unknown Code"
Else
AddStockForm.Controls("Name" & x).Caption = Name
End If
End Sub
The sub takes the user input in the target box (e.g. Code1) and finds the corresponding name and writes it to the label (e.g. Name1). HOWEVER, the product codes are either strings, alphanumeric and plain text, OR numbers. For stupid reasons beyond my control, some codes have to be numbers, others have to contain letters.
This code works PERFECTLY for any code with a character in it (MYCODE or 500A) but not numbers, it writes "Unknown code" for any number, and they are in the lookup range. I have searched around stackoverflow and answers suggest declaring as variants, I've done this, even by assigning Controls().Text as a variant before using it in VLookup. I suspect the problem is
AddStockForm.Controls("Code" & x).Text
is a string. But I cannot convert to an INT because the user input might be a number or string.
Any ideas?
One thing you can do is to create a separate function which has the separate parts you want to do. In this instance, we are checking the input value first. If this is numerical we want to try doing the lookup as a string, then as a number if that fails. If the input value is not numerical we can go ahead and do the lookup as normal.
Public Function lookupStringOrInt(inputValue As Variant, tableArray As Range, colIndexNum As Long, Optional rangeLookup As Boolean) As Variant
If IsNumeric(inputValue) Then
lookupStringOrInt = Application.IfError(Application.VLookup(inputValue & "", tableArray, colIndexNum, rangeLookup), Application.VLookup(inputValue * 1, tableArray, colIndexNum, rangeLookup))
Else
lookupStringOrInt = Application.VLookup(inputValue, tableArray, colIndexNum, rangeLookup)
End If
End Function
You can then call this in your code with the line
name = lookupStringOrInt(AddStockForm.Controls("Code" & x) & "", Sheet1.Range("B:C"), 2, False)
If the value you are looking for does not exist, the function will return 'Error 2042'. You can choose to handle this however you like.

Modifiying and concatenating header titles chosen depending on body criteria

I have the following Excel table used to calculate the overtime hours worked.
I want the last two columns to be auto-generated, preferably with formulas, so that the user can see on which dates the employees have worked OT.
The example output for Bob would be:
Dates worked Normal OT : "2nd, 3rd, 4th, 5th, 10th & 12th"
Dates worked Double OT : "6th, 7th & 13th"
Please note that I don't have Excel 2016, and therefore can't use TEXTJOIN(). Also note that the dates for Week 1 and Week 2 are stored in number format, not date format, so the use of WEEKDAY() is also not possible.
P.S. I have already tried a TextJoin UDF but it doesn't seem to work since I have a lot of criteria within the formula.
The working formula for TEXTJOIN in Excel 2016 is this:
=TEXTJOIN(", ",TRUE,IF(WEEKDAY($B$3:$O$3,2)<6,IF($B5:$O5>0,TEXT($B$3:$O$3,"dd/mm/yyyy"),""),""))
This is using date formats. The UDF doesn't seem to work with these parameters.
I am ignoring everything in the PS at the end of your question as Jeeped is right in that it is contradictory to the main body and screenshot.
Without using a UDF, the formula would be much too complicated. Don't worry, I have supplied my own basic TEXTJOIN() UDF that definitely works.
All the following formulae need to be "array-entered" (by pressed Ctrl+Shift+Enter) in a single cell, and then copied/filled down. (Remember not to copy the starting { and ending }.)
The only difference in the two formulae is that one uses the comparison <5 whilst the other uses >=5, and each one refers to the appropriate "No. of Days" cell.
This first formula needs to be array-entered into cell T5 (Bob's "Dates Worked Normal OT") and then filled down:
{=SUBSTITUTE(TEXTJOIN(", ", TRUE, IF((MOD(COLUMN($B5:$O5)-COLUMN($B5), 7)<5)*($B5:$O5>0), $B$3:$O$3 & CHOOSE(IF($B$3:$O$3<4, $B$3:$O$3, IF($B$3:$O$3<21, 4, IF($B$3:$O$3<24, $B$3:$O$3-20, IF($B$3:$O$3<31, 4, 1)))), "st", "nd", "rd", "th"), "")), ", ", " & ", MAX(1, S5-1))}
The expanded, easier to read, version of the above formula (it will also work if you copy-paste it):
{=
SUBSTITUTE(
TEXTJOIN(
", ",
TRUE,
IF(
(MOD(COLUMN($B5:$O5)-COLUMN($B5), 7)<5)*($B5:$O5>0),
$B$3:$O$3
&
CHOOSE(
IF($B$3:$O$3<4, $B$3:$O$3, IF($B$3:$O$3<21, 4, IF($B$3:$O$3<24, $B$3:$O$3-20, IF($B$3:$O$3<31, 4, 1)))),
"st", "nd", "rd", "th"
),
""
)
),
", ",
" & ",
MAX(1, R5-1)
)}
This second formula needs to be array-entered into cell U5 (Bob's "Dates Worked Double OT") and then filled down:
{=SUBSTITUTE(TEXTJOIN(", ", TRUE, IF((MOD(COLUMN($B5:$O5)-COLUMN($B5), 7)>=5)*($B5:$O5>0), $B$3:$O$3 & CHOOSE(IF($B$3:$O$3<4, $B$3:$O$3, IF($B$3:$O$3<21, 4, IF($B$3:$O$3<24, $B$3:$O$3-20, IF($B$3:$O$3<31, 4, 1)))), "st", "nd", "rd", "th"), "")), ", ", " & ", MAX(1, S5-1))}
The expanded version of the above formula is:
{=
SUBSTITUTE(
TEXTJOIN(
", ",
TRUE,
IF(
(MOD(COLUMN($B5:$O5)-COLUMN($B5), 7)>=5)*($B5:$O5>0),
$B$3:$O$3
&
CHOOSE(
IF($B$3:$O$3<4, $B$3:$O$3, IF($B$3:$O$3<21, 4, IF($B$3:$O$3<24, $B$3:$O$3-20, IF($B$3:$O$3<31, 4, 1)))),
"st", "nd", "rd", "th"
),
""
)
),
", ",
" & ",
MAX(1, S5-1)
)}
Notes:
As mention above, the formulae rely on the availability/accuracy of the "No. of Days" cells in order to work correctly.
These formulae are pretty straightforward:
(MOD(COLUMN($B5:$O5)-COLUMN($B5), 7)>=5)*($B5:$O5>0) is just an array-formula friendly way of writing AND((…), (…));
The only sneaky thing is the use of the CHOOSE() function with four nested IF()s to select the ordinal indicator.
Don't forget to not include the { at the start, and the } at the end of the formulae when copy-pasting. These are just used to show that a formula needs to be array-entered.
My version of the TEXTJOIN UDF:
'============================================================================================
' Module : <any standard module>
' Version : 0.1.0
' Part : 1 of 1
' References : Optional - Microsoft VBScript Regular Expressions 5.5 [VBScript_RegExp_55]
' Source : https://stackoverflow.com/a/49218794/1961728
'============================================================================================
Public Function TEXTJOIN( _
ByRef delimiter As String, _
ByRef ignore_empty As Boolean, _
ByRef text1 As Variant _
) _
As String
Dim ƒ As Excel.WorksheetFunction: Set ƒ = Excel.WorksheetFunction
Const DELIMITER_ As String = "#"
Const PATTERN_ As String = "^(?:#)+|(?:#)+$|(#){2,}"
Static rexDelimiterEscaper As Object ' VBScript_RegExp_55.RegExp ' ## Object
Static rexEmptyIgnorer As Object ' VBScript_RegExp_55.RegExp ' ## Object
If rexEmptyIgnorer Is Nothing _
Then
Set rexEmptyIgnorer = CreateObject("VBScript.RegExp") ' New VBScript_RegExp_55.RegExp ' ## CreateObject("VBScript.RegExp")
With rexEmptyIgnorer
.Global = True
.Pattern = PATTERN_ ' Replacement = "$1"
End With
Set rexDelimiterEscaper = CreateObject("VBScript.RegExp") ' New VBScript_RegExp_55.RegExp ' ## CreateObject("VBScript.RegExp")
With rexDelimiterEscaper
.Global = True
.Pattern = "(.)" ' Replacement = "\$1"
End With
End If
Dim varText1 As Variant
Select Case TypeName(text1)
Case "Range":
varText1 = ƒ.Transpose(text1.Value2)
If text1.Rows.Count = 1 Then
varText1 = ƒ.Transpose(varText1)
If text1.Columns.Count = 1 Then varText1 = Array(varText1)
End If
Case "Variant()":
varText1 = text1
Case Else:
varText1 = Array(text1)
End Select
If ignore_empty _
Then
With rexEmptyIgnorer
.Pattern = Replace(PATTERN_, DELIMITER_, rexDelimiterEscaper.Replace(delimiter, "\$1"))
TEXTJOIN = .Replace(Join(varText1, delimiter), "$1")
End With
Else
TEXTJOIN = Join(varText1, delimiter)
End If
End Function
Notes:
This is not a proper poly-fill:
The first two arguments are not optional;
If you no not wish to use a delimiter, you must pass an empty string as the first parameter.
There is only one other (also required) argument allowed.
You can pass in anything for the third argument, except a multi-dimension array/range. Doing so will result in a #VALUE! error.
It should be very fast, especially for large inputs, as it doesn't use any loops. If you aren't ignoring empty values, it will be lightning fast. Ignoring them will be slower as a couple of regexes and an extra string manipulation have to be used as well.

VBA - Excel : Vlookup crashes my program when no match found

In my program, the user types a Zip Code and gets as an output information related to the Zip Code (province, city, district). To do this, I use the Vlookup function.
So, the user :
Types a Zip code in the main sheet
The program search in a database (in another sheet) in which Zip Code are associated to City, Province, District.
When there is a match, it sends the result to the main pages, so the user can get a city, province, district just by typing the Zip Code. Quite simple process.
I use this code to do so :
If Range("J9").Value <> "N/A" Then 'if there is actually a zip code entered by the user (if not, it will be "N/A")
cityZip = Application.WorksheetFunction.VLookup(sMain.Range("J9").Value,
sZipCodes.Range("B2:E864"), 3, False)
barangayZip = Application.WorksheetFunction.VLookup(sMain.Range("J9").Value,
sZipCodes.Range("B2:E864"), 2, False)
provinceZip = Application.WorksheetFunction.VLookup(sMain.Range("J9").Value,
sZipCodes.Range("B2:E864"), 4, False)
sMain.Range("J7").Value = provinceZip
sMain.Range("J13").Value = cityZip
sMain.Range("J16").Value = barangayZip
Else
End If
It works perfectly when there is a Zip Code which is in my database. But if not, it crashes the execution of the program and I have an error message (like "execution error '1004', unable to read the Vlookup ...).
How to modify my code to just say that if there is no match, then it should just do nothing? I don't know how to introduce this request in a Vlookup function.
Thanks in advance !
EDIT : here is my new code, after following Tim Williams suggestion :
'Using Zip Code
If Range("J9").Value <> "N/A" Then
provinceZip = Application.Lookup(sMain.Range("J9").Value, sZipCodes.Range("B2:E907"), 4, False)
If IsError(provinceZip) = False Then
cityZip = Application.Lookup(sMain.Range("J9").Value, sZipCodes.Range("B2:E907"), 3, False)
barangayZip = Application.Lookup(sMain.Range("J9").Value, sZipCodes.Range("B2:E907"), 2, False)
sMain.Range("J7").Value = provinceZip
sMain.Range("J13").Value = cityZip
sMain.Range("J16").Value = barangayZip
Else
'do nothing
End If
End If
My error is on this line :
provinceZip = Application.Lookup(sMain.Range("J9").Value, sZipCodes.Range("B2:E907"), 4, False)
=> Error 1004, invalid number of arguments
You should read up on VBA error handling. A source such as http://www.cpearson.com/excel/errorhandling.htm might help. That said, try the following code.
You want something like:
Public Function SafeVlookup(lookup_value, table_array, _
col_index, range_lookup, error_value) As Variant
On Error Resume Next
Err.Clear
return_value = Application.WorksheetFunction.VLookup(lookup_value, _
table_array, col_index, range_lookup)
If Err <> 0 Then
return_value = error_value
End If
SafeVlookup = return_value
On Error GoTo 0
End Function
In your code you might call it like:
cityZip = SafeVlookup(sMain.Range("J9").Value, sZipCodes.Range("B2:E864"), 3, _
False, "")
The last parameter is the default value to return if the vlookup failed. So in this example it'd return an empty string.
I usually wrap the vlookup() with an iferror() which contains the default value.
The syntax would be as follows:
iferror(vlookup(....), <default value when lookup fails>)
You can also do something like this:
Dim result as variant
result = Application.vlookup(......)
If IsError(result) Then
' What to do if an error occurs
Else
' what you would normally do
End if
You changed from Vlookup to Lookup, which has less arguments. Using only 2 arguments, you should be fine: provinceZip = Application.Lookup(sMain.Range("J9").Value, sZipCodes.Range("B2:E907") )
SafeVlookup is a good function.
I am still learning VB.
I changed like this and it works for me.
Function SafeVlookup(lookup_value, _
range_lookup, col_index, error_value) As Variant
.....
return_value = Application.WorksheetFunction.vlookup(lookup_value, _
range_lookup, col_index, error_value)
....
End Function
Hope I can use it like this.

Changing array values in a VBA dictionary

I have a piece of code that does not seem to do what it is expected to do. VBA Arrays are mutable by all means, but it seems that when they are stored into a Dictionary as values of some keys, they are not mutable anymore. Any ideas?
Sub foo()
Dim mydict As New Dictionary
mydict.Add "A", Array(1, 2, 3)
MsgBox mydict("A")(1)
''# The above shows 2, which is fine
mydict("A")(1) = 34
MsgBox mydict("A")(1)
''# The above also shows 2, which is not fine
End Sub
It seems you'll need yet to set another var to update the array value.
mArray = mydict.Item(1)
mArray(1) = 34
mydict.Item(1) = mArray
I created a Procedure to solve the same issue, so I could keep it as a "oneliner":
Private Sub pReplaceDicArray(Dic As Object, kEy As Variant, Element As Integer, NewValue)
Dim tempArray As Variant
tempArray = Dic(kEy)
tempArray(Element) = NewValue
Dic(kEy) = tempArray
End Sub
' call as:
' Call mReplaceDicArray(Dic, "A", 1, 8)
I would have written this answer as a comment to Mr. Irizarry's answer, but I'm not allowed. Anyway.... I tried writing that last line of code (below) to assign the array to the first item of the dictionary, but it didn't work. The array in that item remained as it was before.
mydict.items(1) = mArray
Based on what I read elsewhere, it seems to have to do with the instance of the dictionary you're calling upon. I changed it to the following line and it worked.
mydict(mydict.keys(1)) = mArray
I'm still not sure why that is the case, but there it is.
Copy the Array and update the value:
mydict("A") = Array(mydict("A")(0), 34, mydict("A")(2))

Resources