I want to be able to evaluate a formula in a cell (in excel) that has descriptions inbetween the values.
For example, I'll have 3hrs*2ppl + 4 in the cell, and I'll want to evaluate it in another cell to return the numerical answer (eg. 10) in this case.
Can anyone help me?
Ps. I don't know much about Visual Basic but can create the macro if the code is already written for me.
Try this vba function. It will only work for the four basic operations.
Function sEvalFormula(sInput As String) As String
Dim lLoop As Long, sSpecialChars As String, sTemp As String
sSpecialChars = "0123456789-+*/()=."
For lLoop = 1 To Len(sInput)
If InStr(sSpecialChars, Mid(sInput, lLoop, 1)) > 0 Then sTemp = sTemp & Mid(sInput, lLoop, 1)
Next
sEvalFormula = Evaluate(sTemp)
End Function
First, enter the following UDF in a standard module:
Public Function evall(s As String) As Variant
l = Len(s)
s2 = ""
For i = 1 To l
ch = Mid(s, i, 1)
If ch Like "[a-z]" Then
Else
s2 = s2 & ch
End If
Next i
evall = Evaluate(s2)
End Function
So if A1 contains:
3hrs*2ppl + 4
then
=evall(A1)
will display 10
This UDF discards lower case letters and evaluates the remaining expression.
Another way to do this is by using regular expressions (Regex). See this link for more information on what the patterns mean.
Also, make sure you add ”Microsoft VBScript Regular Expressions 5.5″ as reference to your VBA module (see this link for how to do that).
I'm passing in a cell address, stripping out any letters, and then evaluating the function.
Function RegExpReplace(cell As Range, _
Optional ByVal IsGlobal As Boolean = True, _
Optional ByVal IsCaseSensitive As Boolean = True) As Variant
'Declaring the object
Dim objRegExp As Object
'Initializing an Instance
Set objRegExp = CreateObject("vbscript.regexp")
'Setting the Properties
objRegExp.Global = IsGlobal
objRegExp.pattern = "[a-zA-Z]"
objRegExp.IgnoreCase = Not IsCaseSensitive
'Execute the Replace Method
RegExpReplace = Evaluate(objRegExp.Replace(cell.Text, ""))
End Function
In Cell B1 enter this formula: =RegExpReplace(A1)
Results:
Related
I have been searching and doing some study on all the different posts I could find but can't say this request or question has been discussed before.
This is a basic reverse function, what I´ll like to accomplish is (as I call it) a group reversed function. Will Attach a picture to graphicly explain this better.
The goal is then to use =StrReverse($A1)
Function Reversestr(str As String) As String
Reversestr = StrReverse(Trim(str))
End Function
Please, use the next function:
Function reversePairOfDigits(strText As String) As String
Dim i As Long, strRes As String
For i = 1 To Len(strText) Step 2
strRes = Mid(strText, i, 2) & strRes
Next
reversePairOfDigits = strRes
End Function
It can be used in the next simple way. Select a cell containing the string to be processed and run it:
Sub testReversePairOfDigits()
Debug.Print reversePairOfDigits(ActiveCell.value)
End Sub
You can see the result in Immediate Window (Ctrl + G, being in VBE)
If the strings to be processed are in a specific range, is needed to iterate between its cells and call the supplied function. To make the code faster, the range should be placed in an array, then work on that and finally drop the processed result. If you clearly define the range to be processed, I can show you how to do it efficiently.
Reverse String (UDF)
Option Explicit
Function ReverseString( _
ByVal Word As String, _
Optional ByVal CharCount As Long = 1) _
As String
Dim wLen As Long: wLen = Len(Word)
Dim First As Long: First = wLen Mod CharCount
If First > 0 Then ReverseString = Left(Word, First)
Dim n As Long
For n = First + 1 To wLen Step CharCount
ReverseString = Mid(Word, n, CharCount) & ReverseString
Next n
End Function
Example:
if I have in A1: apple,Orange, Grapes I would like to have missing names in B1:Pineapple,Maa.
If A2: Grapes,Pineapple then I would have in B2:Apple,Orange,Maa
I searched for a solution online, but I find same type for missing numbers only. Please help on this
I'd be glad if I can have a solution here. Thanks.
I tired the below:
Public Function MissingWords As String
Dim temp As String
Temp = Replace (stringList, "")
temp = Replace(temp, "")
Dim arr As Variant
Arr = Split (temp, ", ")
Dim newstrings As String
Newstrings = " Apple,Orange,grapes,pineapple, maa"
Dim i As Long
For i = LBound (arr) To UBound(arr)
Newstrings = Replace (newstrings, arr(I) & ", ", "")
Next
Newstrings = Left$(newstrings, Lena(newstrings) - 1)
Missingstrings = newstrings
End function
If I applied this in excel getting value error
Use the following function in a worksheet like
=GetMissingWordsFromList(A1,"Apple,Orange,Grapes,Pineapple,Maa")
And if A1 is Pineapple,Maa you will get Apple,Orange,Grapes in return.
Note that this is case sensitive so Pineapple and pineapple is not considered the same. Also there must not be any spaces after your commas , because it cannot handle that.
Option Explicit
Public Function GetMissingWordsFromList(ByVal Words As String, ByVal WordsList As String, Optional ByVal Delimiter As String = ",") As String
Dim WordsArr() As String
WordsArr = Split(Words, Delimiter)
Dim WordsListArr() As String
WordsListArr = Split(WordsList, Delimiter)
Dim RetVal As String
Dim Word As Variant
For Each Word In WordsListArr
If Not IsInArray(Word, WordsArr) Then
RetVal = RetVal & IIf(RetVal = vbNullString, "", ",") & Word
End If
Next Word
GetMissingWordsFromList = RetVal
End Function
Private Function IsInArray(ByVal What As String, ByVal InArray As Variant) As Boolean
IsInArray = IsNumeric(Application.Match(What, InArray, 0))
End Function
to make it case insensitive (so it will find Pineapple,Maa in a list like apple,orange,grapes,pineapple,maa) you need to use
WordsArr = Split(LCase(Words), Delimiter)
and
If Not IsInArray(LCase(Word), WordsArr) Then
instead.
the last line for your function should be
MissingWords=NewStrings
Now, your function always returns nothing.
Missingstrings is not defined in the function.
If I have a UDF that has the parameters as such:
=MySampleUDF(150+127.193,1000,240-30-12)
How can I use VBA to reduce the above to this (i.e. calculate & simplify all the parameters):
=MySampleUDF(277.193,1000,198)
I've tried to think of ways that involve Regex, but really there must be a simpler way?
So, you want to Evaluate each parameter in the Formula, and turn it into a single value?
The method below is far from perfect; if your parameter includes a formula, then it will fail (e.g. =MySampleUDF(150+127.193,999+1+PRODUCT(7+3,0),240-30-12) will result in =MySampleUDF(277.193,999+1+PRODUCT(10,0),198)), but it forms an almost-decent starting point, and doesn't require any advanced understanding. There are, undoubtedly, many ways to improve it, with more time.
Sub SimplifyParameters(Target AS Range)
Dim aBrackets AS Variant, bClose As Boolean, aParams AS Variant
Dim lCurrBracket AS Long, lCurrParam As Long, rCurrCell AS Range
Dim sProcessBracket AS String, vEvaluated AS Variant
For Each rCurrCell In Target.Cells 'In case you input more than 1 cell
If Len(rCurrCell.Formula)>0 Then 'Ignore blank cells
aBrackets = Split(rCurrCell.Formula, "(") 'Split by Function
For lCurrBracket = lBound(aBrackets) to UBound(aBrackets)
aProcessBracket = aBrackets(lCurrBracket)
bClose = (Right(sProcessBracket,1)=")")
If bClose Then sProcessBracket = Left(sProcessBracket, Len(sProcessBracket)-1)
aParams = Split(sProcessBracket, ",") 'Split by Parameter
For lCurrParam = lBound(aParams) to uBound(aParams)
vEvaluated - Evaluate(aParams(lCurrParam))
If Not IsError(vEvaluated) Then aParams(lCurrParam) = vEvaluated
Next lCurrParam
aBrackets(lCurrBracket) = Join(aParams, ",") & IIF(bClose, ")", "") 'Recombine Parameters
Next lCurrBracket
rCurrCell.Formula = Join(aBrackets, "(") 'Recombine Functions
End If
Next rCurrCell
End Sub
It Splits the Formula on "(", to separate functions
"=MySampleUDF(150+127.193,1000,240-30-12)"
[0] = "=MySampleUDF"
[1] = "150+127.193,1000,240-30-12)"
Then it goes through those, removes the ")", and Splits them on ","
"=MySampleUDF"
[0] = "=MySampleUDF"
"150+127.193,1000,240-30-12"
[0] = "150+127.193"
[1] = "1000"
[2] = "240-30-12"
Then it runs the Evaluate function on each of those and, if the result is not an error, substitutes it in
Evaluate("=MySampleUDF") = Error 2029
Evaluate("150+127.193") = 277.193
Evaluate("1000") = 1000
Evaluate("240-30-12") = 198
Then it Joins the Parameters back together, and restores any removed ")"
Join(Array("=MySampleUDF"), ",") & "" = "=MySampleUDF"
Join(Array(277.193, 1000, 198), ",") & ")" = "277.193,1000,198)"
Finally, it Joins the Functions back together
Join(Array("=MySampleUDF", "277.193,1000,198)"), "(") = "=MySampleUDF(277.193,1000,198)"
Here is a subroutine that takes the selected cell and parses out the arguments of the any function, then evaluates each one and re-composes the formula definition.
For example the selected cell has =SUM(1+2+3,10) as formula.
After calling the sub the cell has =SUM(6,10) as formula
Public Sub EvalParams()
Dim r As Range
For Each r In Selection
Dim f As String
f = r.Formula
If Left(f, 1) = "=" Then
Dim i_open As Long
i_open = InStr(2, f, "(")
Dim id As String
' Get UDF name
id = Mid(f, 2, i_open - 2)
Dim i_close As Long
i_close = InStr(i_open + 1, f, ")")
Dim args() As String
' Seperate arguments by comma
args = VBA.Split(Mid(f, i_open + 1, i_close - i_open - 1), ",")
Dim i As Long
' Evaluate each argument separately
For i = 0 To UBound(args)
args(i) = CStr(Evaluate(args(i)))
Next i
' Compose formula again
f = "=" & id & "(" & VBA.Join(args, ",") & ")"
r.Formula = f
End If
Next r
End Sub
NOTE: This will fail if you have multiple function calls in the formula, like
=SUM(1,2,3) + SUM(4,5)
Consider the following example: Lets say you want to make a function "JoinIfs" that works just like SUMIFS except instead of adding the values in the SumRange, it concatenates the values in "JoinRange". Is there a way to nest the ParamArray as it seems to be done in SUMIFS?
SUMIFS(sum_range, criteria_range1, criteria1, [criteria_range2, criteria2], ...)
I imagine the declaration should look something like this:
Function JoinIfs(JoinRange As Variant, _
Delim As String, _
IncludeNull As Boolean, _
ParamArray CritArray(CriteriaRange As Variant, Criteria As Variant)) As String
But nothing I try seems to compile and there might not be a way to nest ParamArrays. But the existence of functions like SUMIFS and COUNTIFS seems to suggest there might be a way to nest the ParamArrays.
This question duplicates AlexR's question Excel UDF with ParamArray constraint like SUMIFS. But that was posted a few years ago with no response so either the question didn't get enough attention or it was misunderstood.
Edit for clarification: This question is specifically about nesting ParamArrays. I'm not trying to find alternative methods of achieving the outcome of the example above. Imagine nesting ParamArrays on a completely different fictional function like "AverageIfs"
As per the documentation for the Function statement and Sub statement, a Function or Sub can only contain 1 ParamArray, and it must be the last argument.
However, you can pass an Array as an Argument to a ParamArray. Furthermore, you can then check how many elements are in the ParamArray, and throw an error if it isn't an even number. For example, this demonstration takes a list of Arrays, and which element in that array to take, and outputs another array with the results:
Sub DemonstrateParamArray()
Dim TestArray As Variant
TestArray = HasParamArray(Array("First", "Second"), 0)
MsgBox TestArray(0)
Dim AnotherArray As Variant
AnotherArray = Array("Hello", "World")
TestArray = HasParamArray(AnotherArray, 0, AnotherArray, 1)
MsgBox Join(TestArray, " ")
End Sub
Function HasParamArray(ParamArray ArgList() As Variant) As Variant
Dim ArgumentCount As Long, WhichPair As Long, Output() As Variant, WhatElement As Long
ArgumentCount = 1 + UBound(ArgList) - LBound(ArgList)
'Only allow Even Numbers!
If ArgumentCount Mod 2 = 1 Then
Err.Raise 450 '"Wrong number of arguments or invalid property assignment"
Exit Function
End If
ReDim Output(0 To Int(ArgumentCount / 1) - 1)
For WhichPair = LBound(ArgList) To ArgumentCount + LBound(ArgList) - 1 Step 2
WhatElement = ArgumentCount(WhichPair + 1)
Output(Int(WhichPair / 2)) = ArgumentCount(WhichPair)(WhatElement)
Next WhichPair
HasParameterArray = Output
End Function
(A list of built-in error codes for Err.Raise can be found here)
It seems like nesting a ParamArray is not possible.
I was hoping to get a function that looks like Excel's built in functions.
SUMIFS, for example seems to group pairs of parameters in a very neat way.
Based on the inputs of some users I made the following Function which seems to work quite well.
Function SJoinIfs(JoinRange As Variant, Sep As String, IncludeNull As Boolean, ParamArray CritArray() As Variant) As Variant
'Concatenates text based on multple criteria similar to SUMIFS.
'Sizes of ranges CritArray (0, 2, 4 ...) must match size of range JoinRange. CritArray must have an even amount of elements
'Elements of CritArray (1, 3, 5 ...) must be single values
Set JoinList = CreateObject("System.Collections.Arraylist")
'Set FinalList = CreateObject("System.Collections.Arraylist")
For Each DataPoint In JoinRange
JoinList.Add (CStr(DataPoint))
Next
JoinArray = JoinList.ToArray
CriteriaCount = UBound(CritArray) + 1
If CriteriaCount Mod 2 = 0 Then
CriteriaSetCount = Int(CriteriaCount / 2)
Set CriteriaLists = CreateObject("System.Collections.Arraylist")
Set CriteriaList = CreateObject("System.Collections.Arraylist")
Set MatchList = CreateObject("System.Collections.Arraylist")
For a = 0 To CriteriaSetCount - 1
CriteriaList.Clear
For Each CriteriaTest In CritArray(2 * a)
CriteriaList.Add (CStr(CriteriaTest))
Next
If CriteriaList.count <> JoinList.count Then 'Ranges are different sizes
SJoinIfs = CVErr(xlErrRef)
Exit Function
End If
MatchList.Add (CStr(CritArray((2 * a) + 1)))
CriteriaLists.Add (CriteriaList.ToArray)
Next
JoinList.Clear
For a = 0 To UBound(JoinArray)
AllMatch = True
For b = 0 To MatchList.count - 1
AllMatch = (MatchList(b) = CriteriaLists(b)(a)) And AllMatch
Next
If AllMatch Then JoinList.Add (JoinArray(a))
Next
SJoinIfs = SJoin(Sep, IncludeNull, JoinList)
Else 'Criteria Array Size is not even
SJoinIfs = CVErr(xlErrRef)
Exit Function
End If
End Function
This function makes use of another function SJoin() which I adapted some time ago based on the answer provided by Lun in his answer to How to replicate Excel's TEXTJOIN function in VBA UDF that allows array inputs.
I have adapted this Function to include the use of Numericals, VBA Arrays and Arraylists as well.
On Error Resume Next
'Sep is the separator, set to "" if you don't want any separator. Separator must be string or single cell, not cell range
'TxtRng is the content you want to join. TxtRng can be string, single cell, cell range or array returned from an array function. Empty content will be ignored
Dim OutStr As String 'the output string
Dim i, j, k, l As Integer 'counters
Dim FinArr(), element As Variant 'the final array and a temporary element when transfering between the two arrays
'Go through each item of TxtRng(), depending on the item type, transform and put it into FinArray()
i = 0 'the counter for TxtRng
j = 0 'the counter for FinArr
k = 0: l = 0 'the counters for the case of array from Excel array formula
Do While i < UBound(TxtRng) + 1
If TypeName(TxtRng(i)) = "String" Then 'specified string like "t"
ReDim Preserve FinArr(0 To j)
FinArr(j) = "blah"
FinArr(j) = TxtRng(i)
j = j + 1
ElseIf TypeName(TxtRng(i)) = "Range" Then 'single cell or range of cell like A1, A1:A2
For Each element In TxtRng(i)
ReDim Preserve FinArr(0 To j)
FinArr(j) = element
j = j + 1
Next
ElseIf TypeName(TxtRng(i)) = "Variant()" Then 'array returned from an Excel array formula
For k = LBound(TxtRng(0), 1) To UBound(TxtRng(0), 1)
For l = LBound(TxtRng(0), 2) To UBound(TxtRng(0), 2)
ReDim Preserve FinArr(0 To j)
FinArr(j) = TxtRng(0)(k, l)
j = j + 1
Next
Next
Else
TJoin = CVErr(xlErrValue)
Exit Function
End If
i = i + 1
Loop
'Put each element of the new array into the join string
For i = LBound(FinArr) To UBound(FinArr)
If FinArr(i) <> "" Then 'Remove this line if you want to include empty strings
OutStr = OutStr & FinArr(i) & Sep
End If
Next
TJoin = Left(OutStr, Len(OutStr) - Len(Sep)) 'remove the ending separator
End Function
Thanks to all who contributed to this question.
I have have two columns populated with text. I want to compare row-wise for any identical words between the two cells. How can this be accomplished with an Excel formula or vba function?
Best regards,
Try the following UDF():
Public Function Kompare(s1 As String, s2 As String) As Boolean
ary = Split(s1, " ")
bry = Split(s2, " ")
Kompare = False
For Each a In ary
For Each b In bry
If a = b Then
Kompare = True
Exit Function
End If
Next b
Next a
End Function
A third column would be needed. IE:
A..........B..........C
Text,1,another...Text,2,another......'=CommonWords(A1,B1,",") (Result another,Text)
In order to be able to use the UDF paste the following:
Function CommonWords(Text1 As Variant, Text2 As Variant, Character As Variant)
Dim ArrayText1 As Variant: ArrayText1 = Split(Text1, Character)
Dim ItemArrayText1 As Variant
Dim ArrayText2 As Variant: ArrayText2 = Split(Text2, Character)
Dim ItemArrayText2 As Variant
Dim SummaryCommonWords As Variant
For Each ItemArrayText1 In ArrayText1
If InStr(Text2, ItemArrayText1) > 0 And InStr(SummaryCommonWords, ItemArrayText1) = 0 Then SummaryCommonWords = IIf(SummaryCommonWords = "", ItemArrayText1, ItemArrayText1 & Character & SummaryCommonWords)
Next ItemArrayText1
For Each ItemArrayText2 In ArrayText2
If InStr(Text1, ItemArrayText2) > 0 And InStr(SummaryCommonWords, ItemArrayText2) = 0 Then SummaryCommonWords = IIf(SummaryCommonWords = "", ItemArrayText2, ItemArrayText2 & Character & SummaryCommonWords)
Next ItemArrayText2
CommonWords = IIf(CStr(SummaryCommonWords) <> "", SummaryCommonWords, "No common words!")
End Function
As an OT:
Wouldn't be better to know which words are repeated to analyze instead of a true, false statement?
You would need to work it to ignore spaces in the words, caps if needed.