Solved: VBA Evaluate function not working in arrays - Need alternate

[wezred]

My column has 10000 combination in each cell of fruits like apple, banana, orange, kiwi. In the next column there are corresponding numbers. For example:

Apple/Banana 10
Apple/Kiwi 12
Kiwi/Orange 30
Orange/Banana 20
Banana/Apple 19

This formula works and sums up all corresponding columns which cells contain the text "apple":




=+SUM(IF(ISNUMBER(SEARCH("Apple",$A$8:$A$10000)),$B$8:$B$10000))
Answer is 41


I tried creating an evaluation function in VBA as I'm planning to use more than 10 criterias, the function looks like this:


Function Txt2F(InputString As String)
Application.Volatile
Txt2F = Evaluate("=(" & InputString & ")")
End Function


However, the following function doesn't work at all:



=+SUM(IF(Txt2F($A$1),Executive!$B$8:$B$10000))
Where cell $A$1 has the text:
ISNUMBER(SEARCH("Apple",$A$8:$A$10000))


I'd like to create an array such that Cell $A$1 has all the criterias, for example:




ISNUMBER(SEARCH("apple",$a$8:$a$10000))*ISNUMBER(SEARCH("banana",$a$8:$a$10000))+ISNUMBER(SEARCH("kiwi",$a$8:$a$10000))
So the function
=+SUM(IF(Txt2F($A$1),Executive!$B$8:$B$10000)) is 71


Anyone here has any ideas or alternatives? I need an evaluation function that works in complex formulas within an array. Furthermore, this should also cover all sort of statistical functions like Percentile and Average.

Thanks.

[RichardSchollar]

Hi

I must admit I'm failing to see why you want to use a UDF for this - especially one you've declared as Volatile. Is there some reason you don't simply want to use a worksheet formula?

Best regards

Richard

[Bob Phillips]

Because he wants to dynamically change the formula. It has been asked many times before and I don't think this type of flexibilty is easily achieved. If limits are set, you can write code, but the limits become self-defeating.

[wezred]

I would use a simple worksheet formula but it'd be too long and not dynamic enough.

Something like a DAverage formula would be good but I can't seem to find anything similar to a DPercentile.

Anyone has UDF for DPercentile?

[Bob Phillips]

Not sure how good it is, but here is one.

target is the range to get the percentile of, percentile is ... well it is the percentile value, data is the data range including the headings, and criteria is the criteria range including headings



Public Function DPERCENTILE(target As Range, percentile As Double, data As Range, criteria As Range)
Dim aryRanges
Dim sFormula As String
Dim rng As Range
Dim i As Long, j As Long
Dim icol As Long, j1 As Long

ReDim aryRanges(1 To criteria.Columns.Count)
For i = 1 To criteria.Columns.Count
icol = Application.Match(criteria.Cells(1, i), data.Rows(1).Cells, 0)
Set rng = data.Cells(2, icol).Resize(data.Rows.Count - 1)
aryRanges(i) = rng.Address
Next i

ReDim aryCriteria(1 To criteria.Rows.Count - 1)
sFormula = "=PERCENTILE(IF("
For i = 1 To criteria.Rows.Count - 1
sFormula = sFormula & "((" & aryRanges(1) & "=""" & criteria.Cells(i + 1, 1).Value & """)"
For j = 1 To criteria.Columns.Count - 1
If criteria.Cells(i + 1, j + 1).Value <> "" Then
If ((Left$(criteria.Cells(i + 1, j + 1).Value, 1) = "<" Or _
Left$(criteria.Cells(i + 1, j + 1).Value, 1) = ">" Or _
Left$(criteria.Cells(i + 1, j + 1).Value, 1) = "=") And _
IsNumeric(Right$(criteria.Cells(i + 1, j + 1).Value, Len(criteria.Cells(i + 1, j + 1).Value) - 1))) Or _
((Left$(criteria.Cells(i + 1, j + 1).Value, 2) = "<=" Or _
Left$(criteria.Cells(i + 1, j + 1).Value, 2) = ">=") And _
IsNumeric(Right$(criteria.Cells(i + 1, j + 1).Value, Len(criteria.Cells(i + 1, j + 1).Value) - 2))) Then
sFormula = sFormula & "*(" & aryRanges(j + 1) & criteria.Cells(i + 1, j + 1).Value & ")"
Else
sFormula = sFormula & "*(" & aryRanges(j + 1) & "=""" & criteria.Cells(i + 1, j + 1).Value & """)"
End If
End If
Next j
sFormula = sFormula & ")+"
Next i
sFormula = Left$(sFormula, Len(sFormula) - 1) & "," & target.Address & ")," & percentile & ")"
DPERCENTILE = Evaluate(sFormula)

End Function

[Bob Phillips]

This may be better, more consistent with the DBASE functions.

You would call it like so

=DPERCENTILE(A4:E10,"Height",30%,A1:F3)

where I have used the help example



Public Function DPERCENTILE(data As Range, field As String, percentile As Double, criteria As Range)
Dim aryRanges
Dim target As Range
Dim sFormula As String
Dim rng As Range
Dim i As Long, j As Long
Dim icol As Long, j1 As Long

'get the target field range
icol = Application.Match(field, data.Rows(1).Cells, 0)
Set target = data.Cells(2, icol).Resize(data.Rows.Count - 1)

'build an array of ranges for each criteria
ReDim aryRanges(1 To criteria.Columns.Count)
For i = 1 To criteria.Columns.Count
icol = Application.Match(criteria.Cells(1, i), data.Rows(1).Cells, 0)
Set rng = data.Cells(2, icol).Resize(data.Rows.Count - 1)
aryRanges(i) = rng.Address
Next i

'build a conditional formula from the criteria
ReDim aryCriteria(1 To criteria.Rows.Count - 1)
sFormula = "=PERCENTILE(IF("
For i = 1 To criteria.Rows.Count - 1
sFormula = sFormula & "((" & aryRanges(1) & "=""" & criteria.Cells(i + 1, 1).Value & """)"
For j = 1 To criteria.Columns.Count - 1
If criteria.Cells(i + 1, j + 1).Value <> "" Then
If ((Left$(criteria.Cells(i + 1, j + 1).Value, 1) = "<" Or _
Left$(criteria.Cells(i + 1, j + 1).Value, 1) = ">" Or _
Left$(criteria.Cells(i + 1, j + 1).Value, 1) = "=") And _
IsNumeric(Right$(criteria.Cells(i + 1, j + 1).Value, Len(criteria.Cells(i + 1, j + 1).Value) - 1))) Or _
((Left$(criteria.Cells(i + 1, j + 1).Value, 2) = "<=" Or _
Left$(criteria.Cells(i + 1, j + 1).Value, 2) = ">=") And _
IsNumeric(Right$(criteria.Cells(i + 1, j + 1).Value, Len(criteria.Cells(i + 1, j + 1).Value) - 2))) Then
sFormula = sFormula & "*(" & aryRanges(j + 1) & criteria.Cells(i + 1, j + 1).Value & ")"
Else
sFormula = sFormula & "*(" & aryRanges(j + 1) & "=""" & criteria.Cells(i + 1, j + 1).Value & """)"
End If
End If
Next j
sFormula = sFormula & ")+"
Next i

sFormula = Left$(sFormula, Len(sFormula) - 1) & "," & target.Address & ")," & percentile & ")"
DPERCENTILE = Evaluate(sFormula)

End Function

[wezred]

Thanks xld for this UDF.

This works fine if the UDF is used in the same worksheet. However, I get a #NUM! when i use this UDF in another worksheet.

I suspect it is the referencing to "data As Range". Note that the reference to "criteria As Range" works even on a different worksheet.

Can't seem to figure out the culprit. Please help!!

[Bob Phillips]

I had thought about that when testing it, but forget to test for it.



Public Function DPERCENTILE(data As Range, field As String, percentile As Double, criteria As Range)
Dim aryRanges
Dim Target As Range
Dim sFormula As String
Dim rng As Range
Dim i As Long, j As Long
Dim icol As Long, j1 As Long

'get the target field range
icol = Application.Match(field, data.Rows(1).Cells, 0)
Set Target = data.Cells(2, icol).Resize(data.Rows.Count - 1)

'build an array of ranges for each criteria
ReDim aryRanges(1 To criteria.Columns.Count)
For i = 1 To criteria.Columns.Count
icol = Application.Match(criteria.Cells(1, i), data.Rows(1).Cells, 0)
Set rng = data.Cells(2, icol).Resize(data.Rows.Count - 1)
aryRanges(i) = rng.Address(, , , True)
Next i

'build a conditional formula from the criteria
ReDim aryCriteria(1 To criteria.Rows.Count - 1)
sFormula = "=PERCENTILE(IF("
For i = 1 To criteria.Rows.Count - 1
sFormula = sFormula & "((" & aryRanges(1) & "=""" & criteria.Cells(i + 1, 1).Value & """)"
For j = 1 To criteria.Columns.Count - 1
If criteria.Cells(i + 1, j + 1).Value <> "" Then
If ((Left$(criteria.Cells(i + 1, j + 1).Value, 1) = "<" Or _
Left$(criteria.Cells(i + 1, j + 1).Value, 1) = ">" Or _
Left$(criteria.Cells(i + 1, j + 1).Value, 1) = "=") And _
IsNumeric(Right$(criteria.Cells(i + 1, j + 1).Value, Len(criteria.Cells(i + 1, j + 1).Value) - 1))) Or _
((Left$(criteria.Cells(i + 1, j + 1).Value, 2) = "<=" Or _
Left$(criteria.Cells(i + 1, j + 1).Value, 2) = ">=") And _
IsNumeric(Right$(criteria.Cells(i + 1, j + 1).Value, Len(criteria.Cells(i + 1, j + 1).Value) - 2))) Then
sFormula = sFormula & "*(" & aryRanges(j + 1) & criteria.Cells(i + 1, j + 1).Value & ")"
Else
sFormula = sFormula & "*(" & aryRanges(j + 1) & "=""" & criteria.Cells(i + 1, j + 1).Value & """)"
End If
End If
Next j
sFormula = sFormula & ")+"
Next i

sFormula = Left$(sFormula, Len(sFormula) - 1) & "," & Target.Address(, , , True) & ")," & percentile & ")"
DPERCENTILE = Evaluate(sFormula)

End Function

[wezred]

Can you take a look at the attached worksheet?

The criteria I'm using doesn't seem to work with this UDF when:

1. Using "<>" and "*" in the criteria to exclude items that contains certain text
2. Having criteria also applied to the field array i.e. "only get the percentile of the count if count is more than 10" does not work
3. Criterias with more than 2 rows are not working
4. Criterias with more than 1 row and 1 column are not working

My guess might be that there are some missing quotation marks and missing if and then statements for "<>".

I was hoping that DPercentile would replicate DAverage but using Percentile.

Thanks for the help so far.

[Bob Phillips]

This was quickly knocked up and not thoroughly tested (I have no use for such a UDF personally), so I am sure it is anything but complete. This addresses this immediate issue, but don't be surprised if there are more later.

[wezred]

Thanks. I think i've got the gist of the formula and am able to customize it. However, i think the limitations now lie on the string of the evaluation function. Apparently, VBA is limited to evaluate upto a certain (255?) number of characters. Anything beyond that would give you a #Value.

You've been a great help in this and it's much appreciated.

Here's my VBA code for all the rest to see:


Public Function DPERCENTILE(data As Range, field As String, percentile As Double, criteria As Range)
Dim aryRanges
Dim Target As Range
Dim sFormula As String
Dim rng As Range
Dim i As Long, j As Long
Dim icol As Long, j1 As Long

'get the target field range
icol = Application.Match(field, data.Rows(1).Cells, 0)
Set Target = data.Cells(2, icol).Resize(data.Rows.Count - 1)

'build an array of ranges for each criteria
ReDim aryRanges(1 To criteria.Columns.Count)
For i = 1 To criteria.Columns.Count
icol = Application.Match(criteria.Cells(1, i), data.Rows(1).Cells, 0)
Set rng = data.Cells(2, icol).Resize(data.Rows.Count - 1)
aryRanges(i) = rng.Address(, , , True)
Next i

'build a conditional formula from the criteria
ReDim aryCriteria(1 To criteria.Rows.Count - 1)
sFormula = "=PERCENTILE(IF("
For i = 1 To criteria.Rows.Count - 1
sFormula = sFormula & "(" & EvaluateCriteria(criteria.Cells(i + 1, 1).Value, aryRanges(1))
For j = 2 To criteria.Columns.Count
If criteria.Cells(i + 1, j).Value <> "" Then
sFormula = sFormula & "*" & EvaluateCriteria(criteria.Cells(i + 1, j).Value, aryRanges(j))
End If
Next j
sFormula = sFormula & ")+"
Next i

sFormula = Left$(sFormula, Len(sFormula) - 1) & "," & Target.Address(, , , True) & ")," & percentile & ")"
DPERCENTILE = Evaluate(Replace(sFormula, "[" & ActiveWorkbook.Name & "]", ""))

End Function
Function EvaluateCriteria(ByVal criteria, ByVal rngAddress) As String
'Number type criteria
If ((Left$(criteria, 1) = "<" Or Left$(criteria, 1) = ">" Or Left$(criteria, _
1) = "=") And IsNumeric(Right$(criteria, Len(criteria) - 1))) Or _
((Left$(criteria, 2) = "<=" Or Left$(criteria, 2) = ">=") And _
IsNumeric(Right$(criteria, Len(criteria) - 2))) Or ((Left$(criteria, 2) = _
"<>") And IsNumeric(Right$(criteria, Len(criteria) - 2))) Then
EvaluateCriteria = "(" & rngAddress & criteria & ")"
'Character type criteria - EXCLUDE
ElseIf ((Left$(criteria, 2) = "<>") And Not IsNumeric(Right$(criteria, _
Len(criteria) - 2))) Then
'Fuzzy Matching - EXCLUDE
If Mid$(criteria, 3, 1) = "*" And Right$(criteria, 1) = "*" Then
EvaluateCriteria = "(NOT(ISNUMBER(SEARCH(""" & Mid$(criteria, 4, _
Len(criteria) - 4) & """," & rngAddress & "))))"
Else
'Exact Matching - EXCLUDE
EvaluateCriteria = "(" & rngAddress & "<>""" & Right$(criteria, _
Len(criteria) - 2) & """)"
End If
'Character type criteria - INCLUDE
'Fuzzy Matching - INCLUDE
ElseIf ((Left$(criteria, 1) = "*") And (Right$(criteria, 1) = "*") And Not _
IsNumeric(Right$(criteria, Len(criteria) - 1))) Then
EvaluateCriteria = "(ISNUMBER(SEARCH(""" & Mid$(criteria, 2, _
Len(criteria) - 2) & """," & rngAddress & ")))"
Else
EvaluateCriteria = "(" & rngAddress & "=""" & criteria & """)"
End If
End Function

[Bob Phillips]

Probably a better way would be to evaluate all of the criteria building an array of cell references, and then pass that array to the PERCENTILE function.

If I get some time, I might play with that (is that last version of code functionally any different from my last posting?).

[wezred]

I've made changes EvaluateCriteria to include different criteria types.

Would be interesting to see your result in this regard. Thanks.

[Bob Phillips]

Here is a first cut of a more resilient version.

It needs tidying up and finalisuing, but I thought I would post it to show you where I was going



Public Function DPERCENTILE(data As Range, field As String, percentile As Double, criteria As Range)
Dim aryRanges
Dim Target As Range
Dim sFormula As String
Dim sTemp As String
Dim rng As Range
Dim i As Long, j As Long
Dim rtn As Long
Dim aryFieldValues
Dim aryRows
Dim iRow As Long

ReDim aryRows(1 To criteria.Rows.Count - 1)
iRow = 0

'get the target field range
icol = Application.Match(field, data.Rows(1).Cells, 0)
Set Target = data.Cells(2, icol).Resize(data.Rows.Count - 1)

'build an array of ranges for each criteria
ReDim aryRanges(1 To criteria.Columns.Count)
For i = 1 To criteria.Columns.Count
icol = Application.Match(criteria.Cells(1, i), data.Rows(1).Cells, 0)
Set rng = data.Cells(2, icol).Resize(data.Rows.Count - 1)
aryRanges(i) = rng.Address(, , , True)
Next i

'build a conditional formula from the criteria
ReDim aryCriteria(1 To criteria.Rows.Count - 1)
For i = 1 To criteria.Rows.Count - 1
sFormula = ""
For j = 1 To criteria.Columns.Count
If criteria.Cells(i + 1, j).Value <> "" Then
sTemp = EvaluateCriteria(criteria.Cells(i + 1, j).Value, aryRanges(j), rtn)
If rtn = -1 Then
DPERCENTILE = CVErr(xlErrRef)
Exit Function
Else
sFormula = sFormula & "*" & sTemp
End If
End If
Next j
sFormula = "=INDEX(" & Right$(sFormula, Len(sFormula) - 1) & _
"*(ROW(" & Target.Address(, , , True) & _
")-ROW(" & Target.Cells(1, 1).Address(, , , True) & ")+1),0)"
sFormula = Replace(sFormula, "[" & ActiveWorkbook.Name & "]", "")
aryFieldValues = Evaluate(sFormula)
iRow = iRow + 1
aryRows(iRow) = aryFieldValues
Next i

DPERCENTILE = Evaluate("=PERCENTILE(" & ExtractFields(Target, aryRows) & "," & percentile & ")")

End Function

Function EvaluateCriteria(ByVal criteria, ByVal rngAddress, rtn As Long) As String
Dim sChar1 As String
Dim sChar2 As String

rtn = 0 'no error is default

sChar1 = Left$(criteria, 1)
sChar2 = Mid$(criteria, 2, 1)

Select Case sChar1

Case "<"

Select Case sChar2

Case "="
If IsNumeric(Right$(criteria, Len(criteria) - 2)) Then
EvaluateCriteria = "(" & rngAddress & criteria & ")"
Else
rtn = -1
End If

Case ">"

If IsNumeric(Right$(criteria, Len(criteria) - 2)) Then
EvaluateCriteria = "(" & rngAddress & criteria & ")"
Else
If Mid$(criteria, 3, 1) = "*" And Right$(criteria, 1) = "*" Then
EvaluateCriteria = "(NOT(ISNUMBER(SEARCH(""" & Mid$(criteria, 4, _
Len(criteria) - 4) & """," & rngAddress & "))))"
Else
EvaluateCriteria = "(" & rngAddress & "<>""" & Right$(criteria, _
Len(criteria) - 2) & """)"
End If
End If

Case Else
If IsNumeric(Right$(criteria, Len(criteria) - 2)) Then
EvaluateCriteria = "(" & rngAddress & criteria & ")"
Else
rtn = -1
End If

End Select

Case ">"

Select Case sChar2

Case "="
If IsNumeric(Right$(criteria, Len(criteria) - 2)) Then
EvaluateCriteria = "(" & rngAddress & criteria & ")"
Else
rtn = -1
End If

Case Else
If IsNumeric(Right$(criteria, Len(criteria) - 2)) Then
EvaluateCriteria = "(" & rngAddress & criteria & ")"
Else
rtn = -1
End If

End Select

Case "="

Select Case sChar2

Case ">"
If IsNumeric(Right$(criteria, Len(criteria) - 2)) Then
EvaluateCriteria = "(" & rngAddress & criteria & ")"
Else
rtn = -1
End If

Case "<"
If IsNumeric(Right$(criteria, Len(criteria) - 2)) Then
EvaluateCriteria = "(" & rngAddress & criteria & ")"
Else
rtn = -1
End If

Case Else
If IsNumeric(Right$(criteria, Len(criteria) - 2)) Then
EvaluateCriteria = "(" & rngAddress & criteria & ")"
Else
If Mid$(criteria, 2, 1) = "*" And Right$(criteria, 1) = "*" Then
EvaluateCriteria = "(ISNUMBER(SEARCH(""" & Mid$(criteria, 3, _
Len(criteria) - 3) & """," & rngAddress & ")))"
Else
EvaluateCriteria = "(" & rngAddress & "=""" & Right$(criteria, _
Len(criteria) - 1) & """)"
End If
End If

End Select

Case Else

If IsNumeric(Right$(criteria, Len(criteria) - 2)) Then
EvaluateCriteria = "(" & rngAddress & criteria & ")"
Else
EvaluateCriteria = "(" & rngAddress & "=""" & criteria & """)"
End If

End Select

End Function

Private Function ExtractFields(ByVal Target As Range, ByVal RowNums) As String
Dim oCollRows As Collection
Dim aryRows
Dim iRow As Long
Dim iRowNum As Long
Dim item
Dim sArray As String

Set oCollRows = New Collection
On Error Resume Next
For iRow = LBound(RowNums) To UBound(RowNums)
aryRows = RowNums(iRow)
For iRowNum = LBound(aryRows, 1) To UBound(aryRows, 1)
If aryRows(iRowNum, 1) <> 0 Then _
oCollRows.Add CStr(aryRows(iRowNum, 1)), CStr(aryRows(iRowNum, 1))
Next iRowNum
Next iRow
On Error GoTo 0

ReDim ary(1 To 1)
iRow = 1
sArray = "{"
For Each item In oCollRows
ReDim Preserve ary(1 To iRow)
sArray = sArray & Target.Cells(oCollRows.item(iRow), 1) & ","
iRow = iRow + 1
Next item
sArray = Left$(sArray, Len(sArray) - 1) & "}"
Set oCollRows = Nothing

ExtractFields = sArray

End Function