Excel UDF doubles value of the evaluated SUB - excel

1. I was trying to answer VBA UDF to split string array and got an unpleasant results during computing my UDF.
Public Function mytest(src, dest)
dest.Parent.Evaluate "test(" & src.Address(False, False) & ", " & dest.Address(False, False) & ")"
mytest = "wut"
End Function
Sub test(src As Range, dest As Range)
Dim chr, rows, cols
rows = 0
cols = 0
For chr = 1 To Len(src.Value)
Select Case Mid(src.Value, chr, 1)
Case ","
rows = rows + 1
Case ";"
cols = cols + 1
rows = 0
Case Else
Cells(dest.Row + rows, dest.Column + cols).Value = Cells(dest.Row + rows, dest.Column + cols).Value & Mid(src.Value, chr, 1) '
End Select
Next chr
End Sub
Expected results:
Formula results:
Can someone explain why does it double Value of the cell?
When I debugged test using
Sub ffs()
Call test(Cells(1, 1), Cells(3, 1))
End Sub
I got expected results, so I guess the problem is not in the test Sub?..
2. Whenever I try to add more parameters to Function and Sub (for example delimiters) Function doesn't Evaluate Sub at all
Public Function CellToRange(src, dest, DelimL, DelimC)
dest.Parent.Evaluate "test(" & src.Address(False, False) & ", " & dest.Address(False, False) & ", " & DelimL & ", " & DelimC & ")"
CellToRange = "wut"
End Function
Sub CTR(src As Range, dest As Range, Delim1, Delim2)
Dim chr, rows, cols
rows = 0
cols = 0
For chr = 1 To Len(src.Value)
Select Case Mid(src.Value, chr, 1)
Case Delim1
rows = rows + 1
Case Delim2
cols = cols + 1
rows = 0
Case Else
Cells(dest.Row + rows, dest.Column + cols).Value = Cells(dest.Row + rows, dest.Column + cols).Value & Mid(src.Value, chr, 1) '
End Select
Next chr
End Sub
Please help ._. and thanks in advance.
Solution:
Thanks Billy and Charles Williams.
Change
dest.Parent.Evaluate "CTR(" & src.Address(False, False) & ", " & dest.Address(False, False) & ", " & DelimL & ", " & DelimC & ")"
To
dest.Parent.Evaluate "0+CTR(" & src.Address(False, False) & ", " & dest.Address(False, False) & ", " & DelimL & ", " & DelimC & ")"
Thanks everyone!

The problem lies with the Worksheet.Evaluate method which is being used to get round the restriction that a UDF is not allowed to modify the worksheet structure.
Consider this code
Option Explicit
Public Function dummyudf() As String
Debug.Print "Calling Evaluate method"
ActiveSheet.Evaluate "testsub()"
Debug.Print "Returning From Evaluate method"
dummyudf = "done"
End Function
Sub testsub()
Debug.Print "testsub running"
End Sub
Sub testmacro()
Dim s As String
Debug.Print "testmacro running"
s = dummyudf
End Sub
The UDF dummyudf() uses the Evaluate method to invoke the Sub called testsub(). These are analagous to mytest and test in part 1. of the OP and to CellToRange and CTR in part 2 but are stripped down to the bare minimum.
testsub() can also be invoked directly as a macro. A second macro testmacro invokes dummyudf as a function in VBA.
The following output was obtained from the Immediate Window:
As can be seen
when invoked as a macro: testsub() behaves as expected
when dummyudf() is invoked as a UDF on the worksheet (for example by adding the formula =dummyudf() to cell A1 the Evaluate method appears to call testsub() twice
when dummyudf() is invoked as a function in VBA by running testmacro() as a macro the Evaluate method appears to call testsub() twice.
The documentation here suggests that the Name argument of the Worksheet.Evaluate method should be the name of an object, so it is a bit surprising that it is possible supply the name of a Sub. That it also seems to call any such Sub twice, is even more surprising but does underline the advice given in YowE3K's answer about not using this hack in a UDF. I'd go further: don't use Worksheet.Evaluate with any Sub.

1) It evaluates once when the formula is triggered, and again when cell A3 is updated by the function (as it is one of the cells the formula is dependent on).
2a) You are calling the wrong subroutine (test instead of CTR)
2b) You need to call your second function using something like
=CellToRange(A1;A3;""",""";""";""")
or else change the line in your code calling CTR to be
dest.Parent.Evaluate "CTR(" & src.Address(False, False) & ", " & dest.Address(False, False) & ", """ & DelimL & """, """ & DelimC & """)"
3) I strongly recommend that you do not use this sort of hack to get a UDF to update cells other than the one containing the function.

Related

Function runs in VBA but not the spreadsheet

I have what I think is a relatively simple function I'm running where I'm basically trying to find how much time someone stays waiting in the queue for a call back. It runs great when I'm in the VBA tab, but when I call the function in my spreadsheet I get a #REF! error.
Function TIQ2()
Dim time, count, i As Integer
Dim TIQ
time = 0
count = 0
NumRows = Sheet1.Range("A2", Sheet1.Range("A2").End(xlDown)).Rows.count + 1
For i = 2 To NumRows
If Sheet1.Range("c" & i) = "no" Or Sheet1.Range("c" & i) = "No" Then
If Sheet1.Range("d" & i) = "No" Or Sheet1.Range("d" & i) = "no" Then
time = time + Left(Sheet1.Range("g" & i), 2)
count = count + 1
Debug.Print time, count
End If
End If
Next
TIQ2 = WorksheetFunction.RoundUp(time / count, 0) & " minutes"
Debug.Print TIQ2
End Function
try changing this line. some excel function requieres this syntaxis
TIQ2 = WorksheetFunction.RoundUp(time / count, 0) & " minutes"
'-------------------
TIQ2 =ThisWorkbook.Application.WorksheetFunction.RoundUp(time / count, 0) & " minutes"
Option Explicit
'Public Function fnHelloWorld()
'Function fnTIQ()
Function TIQ2()
MsgBox "Hello World!"
End Function
Sub Test()
Call TIQ2
End Sub
Try this ...
The first two function declarations work OK but the third one does not. The #REF error is produced by the fact that the TIQ2 function name is also a cell reference as #EvR says.

If Statement in for loop VBA

Im tring to get my Function to skip words in my list that arent in my string but it doesnt seem to be working
Iv tried using VBA and excel native commands... however i get the same result
Public Function test(range, y)
step = y
For Each cell In range
If InStr(cell, step, vbTextCompare) <> 0 Then
step = Application.WorksheetFunction.Replace(step,Application.WorksheetFunction.Search(cell, step), Len(cell), UCase(cell))
test = step
End If
Next cell
End Function
When I try to use this Function in Excel I get #VALUE, I suspect this is because not all the values in the list are found in the string however that the reason for the if statement
first you have the variable backwards in the Instr. and you must use the firs criterion if you use the last.
Also if you are looking for complete words then you need to use " " on the search and replace.
Lastly use vba's Replace:
Public Function test(rng As range, y As String)
Dim step As String
step = y
Dim cell As range
For Each cell In rng
If InStr(1, " " & step & " ", " " & cell & " ", vbTextCompare) > 0 Then
step = Replace(" " & step & " ", " " & cell & " ", UCase(" " & cell & " "))
End If
Next cell
test = Application.Trim(step)
End Function

Create several line breaks in excel cell using Excel VBA

I will try to explain the issue as clear as possible.
I have a column in an Excel file and each cell in this column contains a description of some issue. The description has four levels such as Name, Issue, Solution and Result, all these four in the same cell.
I need VBA code that will find each level in each cell and create line break in the cell.
So instead of this:
Name: 123 Issue: My issue: Solution: Try to resolve Result: Resolved.
After the code runs will be like this:
Name: 123 (line break)
Issue: My issue (line break)
Solution: Try to resolve (line break)
Result: Resolved (line break)
Please let me know if there is any solution?
Select the cell containing the data and run:
Sub FixData()
Dim r As Range
Set r = ActiveCell
t = r.Text
t = Replace(t, "Issue:", Chr(10) & "Issue:")
t = Replace(t, "Solution:", Chr(10) & "Solution:")
t = Replace(t, "Result:", Chr(10) & "Result:")
r.Value = t
r.WrapText = True
End Sub
If necessary, you can put this in a loop.
loop through the cells and add linefeeds.
sub makelfs()
dim i as long, j as long, arr as variant, str as string
arr = array("Issue:","Solution:","Result:")
with worksheets("excel file")
for i=2 to .cells(.rows.count, "a column in excel file").end(xlup).row
str = .cells(i, "a column in excel file").value2
for j = lbound(arr) to ubound(arr)
str = replace(str, arr(j), vblf & arr(j))
next j
.cells(i, "a column in excel file") = str
.cells(i, "a column in excel file").wraptext = true
next i
end with
end sub
s = "Name: 123 Issue: My issue: Solution: Try to resolve Result: Resolved."
arr = Split(s, Chr(32))
For Each Item In arr
If cnt > 0 Then
If Right(Item, 1) = ":" Then Item = vbCrLf & Item
End If
output = output & Item & " "
cnt = cnt + 1
Next Item
Debug.Print output
Using a slightly different approach which doesn't rely on Issue, Solution and Result being present.
As said in my comment - look for the first space before the colon and replace it with a line feed (put vbcr in my comment - should be vblf).
Public Function AddLineBreak(Target As Range) As String
Dim lColon As Long
Dim lSpace As Long
Dim sFinal As String
sFinal = Target.Value
lSpace = Len(sFinal)
Do While lSpace <> 0
sFinal = Left(sFinal, lSpace - 1) & Replace(sFinal, " ", vbLf, lSpace, 1)
lColon = InStrRev(sFinal, ":", lSpace - 1)
lSpace = InStrRev(sFinal, " ", lColon)
Loop
AddLineBreak = Trim(sFinal)
End Function
You can call the function in a procedure:
Sub Test()
Dim rCell As Range
For Each rCell In Sheet1.Range("A1:A13")
rCell = AddLineBreak(rCell)
Next rCell
End Sub
or as a worksheet function:
=AddLineBreak(A1)
This assumes an error in the original string you posted:
Name: 123 Issue: My issue: Solution: Try to resolve Result: Resolved. should be
Name: 123 Issue: My issue Solution: Try to resolve Result: Resolved.
(extra colon before Solution which is not shown in your After code example).
Edit - it also means you cannot have spaces in your headings. So you can have " Issue:" or " My_Issue:" but not " My Issue:"

Easier way to use declared Strings in Query in VBA

I'm writing a macro which should run queries to transfer data from excel to a Access database, and everything is working fine, however, if I want to use a String in one of these queries, I've to type them like this:
'" & Lijn & "'
I know that the following code (which is written in VBA) is way easier to write in Javascript, by using question marks and setString:
VBA:
Dim ShiftsQ As String
ShiftsQ = "INSERT INTO Shifts(Lijn, Operator, Ploeg, Teamleider) VALUES ('" & Lijn & "', '" & Operator & "', '" & Ploeg & "', '" & Teamleider & "');"
Javascript:
var ShiftsQ = SQL.prepareStatement(INSERT INTO Shifts(Lijn, Operator, Ploeg, Teamleider) VALUES (?, ?, ?, ?);
ShiftsQ.setString(1, Lijn);
ShiftsQ.setString(2, Operator);
ShiftsQ.setString(3, Ploeg);
ShiftsQ.setString(4, Teamleider);
Is there anyway to write the VBA code like the Javascript one?
As far as I know, there is nothing like the .NET string.Format() method VBA. But you could write your own version of such a function that uses deputys and returns a formatted string.
Private Sub Main()
' Your actual query
' The deputys are indexed in curley brackets (inspired from the .NET syntax of the equivalent function, making your code easy to read for .NET programmers)
Dim qry As String
qry = "SELECT {0}, {1} FROM {2} WHERE {3}"
' The values to set for the deputys in your query
Dim parameters(3) As String
parameters(0) = "firstname"
parameters(1) = "lastname"
parameters(2) = "users"
parameters(3) = "userID = 'M463'"
' For demo purposes, this will display the query in a message box
' Instead of the MsgBox, you would use the formatted query to execute against the database
MsgBox FormatString(qry, parameters)
End Sub
' This is where the magic happens, the deputys in the given string will be replaced with the actual values from the provided array
Private Function FormatString(strInput As String, paramValues() As String)
' This will be our return value
Dim strOutput As String
strOutput = strInput
' Verify that the given count of parameters matches the given count of deputys in the input string
Dim maxParamIndex As Integer
maxParamIndex = UBound(paramValues)
Dim deputyCount As Integer
For i = 1 To Len(strOutput) + 1 Step 1
If Mid(strOutput, i, 3) = "{" & deputyCount & "}" Then
deputyCount = deputyCount + 1
End If
Next
' If there is a mismatch between the count of parameters and the count of deputys, display exception message and exit the function
' Adding +1 to maxParamIndex is neccessary, as maxParamIndex refers to the maximum index (starting at 0, not 1) of the given array and deputyCount refers to the actual count of deputys (starting at 1)
If maxParamIndex + 1 <> deputyCount Then
MsgBox "Number of deputys has to match number of parameters for the given string:" & vbCrLf & strInput, vbCritical, "Exception in Function FormatString"
FormatString = ""
End If
' Iterate through the array and replace the deputys with the given values
For i = 0 To maxParamIndex Step 1
strOutput = Replace(strOutput, "{" & i & "}", paramValues(i))
Next
' return the formatted string
FormatString = strOutput
End Function
Result of example:
If I face this problem I would simply solve it on my own (althoug there might be other "standard" solutions), by defining my own simple, global function (put in in any standard code module)
Public Function S_(str as String) as String
S_ = chr(39) & str & chr(39)
End Function
ShiftsQ = "INSERT INTO Shifts(Lijn, Operator, Ploeg, Teamleider) VALUES (" & S_(Lijn) & ", " & S_(Operator) & ", " & S_(Ploeg) & ", " & S_(Teamleider) & ");"
This way, I will follow a simple and systematic rule in all my project, that is call S_(param) on any parameter of text type in my queries...

How to loop through rows and columns and Concatenate two text cells in Excel VBA?

I am fairly new to Excel Macros and I am looking for a way to loop through the row headings and columns headings and combine them into one cell for each row and column heading until I have combined all of them.
An example of the First Column cell would be "Your Organizations Title"
An Example of the First Row Cell Would be "22. Cheif Investment Officer"
An example of the first combined cell that I want on a new sheet would be this: "22. Chief Investment Officer (Your Organization's Title)
I then want the combined cells on the new sheet to offset one column to the right until it has iterated through all of the rows and columns.
I have just joined the forum and it will not let me post images or I would have. Perhaps this gives a better idea, here is my code now:
Sub Fill()
' Select cell A2, *first line of data*.
Set title = Sheets("Compensation, 3").Range("B6:B500")
Set descr = Sheets("Compensation, 3").Range("C5:AAA5")
' Set Do loop to stop when an empty cell is reached.
Do Until IsEmpty(title.Value)
Do Until IsEmpty(descr.Value)
ActiveCell.Offset(0, 1).Formula = _
"=title.value & "" ("" & descr.value & "")"""
Set descr = descr.Offset(0, 1)
Loop
Set title = title.Offset(1, 0)
Loop
End Sub
When I run it goes puts this into the active cell:
=title.value & " (" & descr.value & ")"
It does not recognize the variables and come up with the NAME error. It also goes into an infinite loop with no output besides the one cell.
Edit:
I cannot answer my own question because I am new to the forum, but using a combination of your answers I have solved the problem!
Here is the finished code:
Sub Fill()
' Select cell A2, *first line of data*.
Set title = Sheets("Compensation, 3").Range("B6")
Set descr = Sheets("Compensation, 3").Range("C5")
offsetCtr = 0
' Set Do loop to stop when an empty cell is reached.
Do Until IsEmpty(title.Value)
Do Until IsEmpty(descr.Value)
ActiveCell.Offset(0, offsetCtr).Formula = title.Value & " (" & descr.Value & ")"
offsetCtr = offsetCtr + 1
Set descr = descr.Offset(0, 1)
Loop
Set descr = Sheets("Compensation, 3").Range("C5")
Set title = title.Offset(1, 0)
Loop
End Sub
Thank you so much!
Option Explicit
Sub GenerateAndPasteFormulaForTitleAndDescription( _
ByVal titlesRange As Range, ByVal descriptionRange As Range, _
ByVal startCellOnDestination As Range)
Dim title As Range
Dim descr As Range
Dim offsetCtr As Long
Dim formulaTemplate As String
Dim newFormula As String
formulaTemplate = "=CONCATENATE([1], '(', [2], ')')"
startCellOnDestination.Worksheet.EnableCalculation = False
For Each title In titlesRange.Cells
For Each descr In descriptionRange.Cells
If title.Value <> "" And descr.Value <> "" Then
newFormula = Replace(formulaTemplate, "[1]", _
title.Address(External:=True))
newFormula = Replace(newFormula, "[2]", _
descr.Address(External:=True))
newFormula = Replace(newFormula, "'", Chr(34))
startCellOnDestination.Offset(0, offsetCtr).Formula = newFormula
offsetCtr = offsetCtr + 1
End If
Next
Next
startCellOnDestination.Worksheet.EnableCalculation = True
End Sub
Here is how to call the above procedure
GenerateAndPasteFormulaForTitleAndDescription _
Sheets("Compensation, 3").Range("B6:B500"), _
Sheets("Compensation, 3").Range("C5:AAA5"), _
Sheets("new sheet").Range("B5")
EDIT: The code loops through combination of title and description, checks if both of them aren't empty and creates a formula. It pastes the formula into the start cell (Sheets("new sheet").Range("B5") in this case) and moved ahead and pastes the next formula in the column next to it
Basically, you are trying to use VBA objects in worksheet functions. It doesn't quite work that way.
Try replacing
"=title.value & "" ("" & descr.value & "")"""
with
=title.value & " (" & descr.value & ")"

Resources