Option Explicit
Const mlMask_Starts As Long = 1
Const mlMask_Contains As Long = 2
Const mlMask_Ends As Long = 4
Const mlMask_Less As Long = 8
Const mlMask_Equals As Long = 16
Const mlMask_Greater As Long = 32
Public Enum TypeOfElement
Type_Unassigned = -1
Type_Condition = 0 'T F
Type_Operator = 1 ' 'AND' 'OR' & /
Type_Bracket = 2 ' ( )
End Enum
Public Type ElementDesc
ElementType As TypeOfElement
Value As String
' The following are only applicable for 'element type 'Condition'
NegateComparison As Boolean 'True if 'NOT'
Comparator As Long 'Bit significant 'starts', 'contains', 'Ends',<,<=, =,<>, >=, >
End Type
Public Function RuleLookup(ByVal LookupValue As String, _
ByRef RuleTable As Range, _
Optional ResultsColumn As Integer = 2) As Variant
Dim bEvaluation As Boolean
Dim iElementPtr As Integer
Dim iCurElementPtr As Integer, iPtr1 As Integer, iLen As Integer
Dim lRuleRow As Long
Dim lComparator As Long, lCurEvaluation As Long
Dim sLookupValue As String
Dim sCurRule As String, sChar As String, sCurDelim As String, sCurValue As String
Dim sCurRuleString As String, sCurRuleRPN As String
Dim uCurElement As ElementDesc, uaElements() As ElementDesc
Dim vaRuleTable() As Variant
Dim vResult As Variant
'-- Normalise & validate LookupValue parameter --
sLookupValue = LCase$(LookupValue)
If sLookupValue = "" Then
RuleLookup = "*** LookupValue is null ***"
Exit Function
End If
'-- Validate ResultsColumn parameter --
If ResultsColumn< 2 Then
RuleLookup = "*** 'ResultsColumn' must be > 1 ***"
Exit Function
End If
'-- Store Rules Table into array & validate RuleTable parameter --
vaRuleTable = Intersect(RuleTable, Sheets(RuleTable.Parent.Name).UsedRange).Value
If UBound(vaRuleTable, 2)< ResultsColumn Then
RuleLookup = "*** Rules table must be at least " & ResultsColumn & " wide ***"
Exit Function
End If
'-- Loop thru rules --
For lRuleRow = 1 To UBound(vaRuleTable, 1)
sCurRule = Trim$(LCase$(CStr(vaRuleTable(lRuleRow, 1))))
iCurElementPtr = 0
iElementPtr = 0
InitialiseElement uCurElement
iCurElementPtr = 1
Do While iCurElementPtr<= Len(sCurRule)
sChar = Mid$(sCurRule, iCurElementPtr, 1)
If sChar = " " Then
ElseIf Mid$(sCurRule & "123", iCurElementPtr, 3) = "and" Then
AddElement InputElement:=uCurElement, Pointer:=iElementPtr, ElementArray:=uaElements
uCurElement.ElementType = Type_Operator
uCurElement.Value = "&"
AddElement InputElement:=uCurElement, Pointer:=iElementPtr, ElementArray:=uaElements
iCurElementPtr = iCurElementPtr + 2
ElseIf InStr("&/", sChar)<> 0 Then
AddElement InputElement:=uCurElement, Pointer:=iElementPtr, ElementArray:=uaElements
uCurElement.ElementType = Type_Operator
uCurElement.Value = sChar
AddElement InputElement:=uCurElement, Pointer:=iElementPtr, ElementArray:=uaElements
ElseIf Mid$(sCurRule & "12", iCurElementPtr, 2) = "or" Then
AddElement InputElement:=uCurElement, Pointer:=iElementPtr, ElementArray:=uaElements
uCurElement.ElementType = Type_Operator
uCurElement.Value = "/"
AddElement InputElement:=uCurElement, Pointer:=iElementPtr, ElementArray:=uaElements
iCurElementPtr = iCurElementPtr + 1
ElseIf Mid$(sCurRule, iCurElementPtr, 3) = "not" Then
uCurElement.NegateComparison = True
iCurElementPtr = iCurElementPtr + 2
ElseIf sChar = "<" Then
uCurElement.Comparator = uCurElement.Comparator Or mlMask_Less
ElseIf sChar = "=" Then
uCurElement.Comparator = uCurElement.Comparator Or mlMask_Equals
ElseIf sChar = ">" Then
uCurElement.Comparator = uCurElement.Comparator Or mlMask_Greater
ElseIf Mid$(sCurRule & "12345", iCurElementPtr, 5) = "starts" Then
uCurElement.Comparator = uCurElement.Comparator Or mlMask_Starts
iCurElementPtr = iCurElementPtr + 4
ElseIf Mid$(sCurRule & "12345678", iCurElementPtr, 8) = "contains" Then
uCurElement.Comparator = uCurElement.Comparator Or mlMask_Contains
iCurElementPtr = iCurElementPtr + 7
ElseIf Mid$(sCurRule & "1234", iCurElementPtr, 4) = "ends" Then
uCurElement.Comparator = uCurElement.Comparator Or mlMask_Ends
iCurElementPtr = iCurElementPtr + 3
ElseIf InStr("()", sChar)<> 0 Then
AddElement InputElement:=uCurElement, Pointer:=iElementPtr, ElementArray:=uaElements
uCurElement.ElementType = Type_Bracket
uCurElement.Value = sChar
AddElement InputElement:=uCurElement, Pointer:=iElementPtr, ElementArray:=uaElements
ElseIf InStr("'""", sChar)<> 0 Then
'-- here if we've got a delimited value --
If uCurElement.ElementType = Type_Unassigned Then uCurElement.ElementType = Type_Condition
uCurElement.Value = ""
sCurDelim = sChar
For iPtr1 = iCurElementPtr + 1 To Len(sCurRule)
sChar = Mid$(sCurRule, iPtr1, 1)
iCurElementPtr = iCurElementPtr + 1
If sChar = sCurDelim Then Exit For
uCurElement.Value = uCurElement.Value & sChar
Next iPtr1
AddElement InputElement:=uCurElement, Pointer:=iElementPtr, ElementArray:=uaElements
Else
'-- Here if we've got a value --
If uCurElement.ElementType = Type_Unassigned Then uCurElement.ElementType = Type_Condition
uCurElement.Value = ""
sCurDelim = ""
For iPtr1 = iCurElementPtr To Len(sCurRule)
sChar = Mid$(sCurRule, iPtr1, 1)
If InStr("() &/", sChar)<> 0 Then
iCurElementPtr = iCurElementPtr - 1
Exit For
End If
iCurElementPtr = iCurElementPtr + 1
uCurElement.Value = uCurElement.Value & sChar
Next iPtr1
AddElement InputElement:=uCurElement, Pointer:=iElementPtr, ElementArray:=uaElements
End If
iCurElementPtr = iCurElementPtr + 1
Loop
If uCurElement.ElementType<> Type_Unassigned Then
AddElement InputElement:=uCurElement, Pointer:=iElementPtr, ElementArray:=uaElements
End If
'Evaluate each element in array & store in string
sCurRuleString = ""
For iPtr1 = 1 To UBound(uaElements)
If uaElements(iPtr1).ElementType = Type_Bracket _
Or uaElements(iPtr1).ElementType = Type_Operator Then
sCurRuleString = sCurRuleString & uaElements(iPtr1).Value
ElseIf uaElements(iPtr1).ElementType = Type_Condition Then
lCurEvaluation = 0
sCurValue = uaElements(iPtr1).Value
iLen = Len(sCurValue)
If iLen<= Len(sLookupValue) Then
If Left$(sLookupValue, iLen) = sCurValue Then lCurEvaluation = lCurEvaluation Or mlMask_Starts
If InStr(sLookupValue, sCurValue)<> 0 Then lCurEvaluation = lCurEvaluation Or mlMask_Contains
If Right$(sLookupValue, iLen) = sCurValue Then lCurEvaluation = lCurEvaluation Or mlMask_Ends
If sLookupValue = sCurValue Then lCurEvaluation = lCurEvaluation Or mlMask_Equals
End If
If sLookupValue< sCurValue Then lCurEvaluation = lCurEvaluation Or mlMask_Less
If sLookupValue > sCurValue Then lCurEvaluation = lCurEvaluation Or mlMask_Greater
bEvaluation = (lCurEvaluation And uaElements(iPtr1).Comparator)<> 0
bEvaluation = bEvaluation Xor uaElements(iPtr1).NegateComparison
If bEvaluation Then
sCurRuleString = sCurRuleString & "T"
Else
sCurRuleString = sCurRuleString & "F"
End If
End If
Next iPtr1
'-- Convert string to RPN --
sCurRuleRPN = InfixToRPN(sCurRuleString)
If Left$(sCurRuleRPN, 1) = "*" Then
RuleLookup = sCurRuleRPN
Exit Function
End If
'-- Evaluate RPN Expression. If evaluates to True ir an error message, Return Result & exit --
vResult = EvaluateRPNExpression(sCurRuleRPN)
If vResult<> False Then
If vResult = True Then
RuleLookup = vaRuleTable(lRuleRow, ResultsColumn)
Else
RuleLookup = vResult
End If
Exit Function
End If
Next lRuleRow
RuleLookup = CVErr(xlErrNA)
End Function
Private Sub AddElement(ByRef InputElement As ElementDesc, _
ByRef Pointer As Integer, _
ByRef ElementArray() As ElementDesc)
If InputElement.ElementType<> Type_Unassigned Then
Pointer = Pointer + 1
ReDim Preserve ElementArray(0 To Pointer)
ElementArray(Pointer).ElementType = InputElement.ElementType
ElementArray(Pointer).Value = InputElement.Value
ElementArray(Pointer).NegateComparison = InputElement.NegateComparison
ElementArray(Pointer).Comparator = InputElement.Comparator
End If
InitialiseElement InputElement
End Sub
Private Sub InitialiseElement(ByRef Elementx As ElementDesc)
Elementx.ElementType = Type_Unassigned
Elementx.NegateComparison = False
Elementx.Comparator = 0
Elementx.Value = ""
End Sub
Private Function InfixToRPN(ByVal InfixString As String) As String
'Algorithm:
' Parse InputString.
' > If T or F, pass directly to output string
' > If Open Bracket, Push onto FILO Stack
' > If Close Bracket, discard it & POP operators from stack to Output String ...
' ... Until we come to an open Bracket, which we discard.
' > If & or /, Pop all operators on stack to output string ...
' ... Until stack is empty or we encounter an open Bracket ...
' ... Then push operator onto stack
Dim bError As Boolean
Dim iPtr As Integer, iLen As Integer
Dim sStack As String, sOutputString As String, sCur As String, sCur1 As String
sOutputString = ""
sStack = ""
For iPtr = 1 To Len(InfixString)
sCur = Mid$(InfixString, iPtr, 1)
If InStr("TF", sCur)<> 0 Then
sOutputString = sOutputString & sCur
ElseIf sCur = "(" Then
sStack = sStack & sCur
ElseIf sCur = ")" Then
sOutputString = sOutputString & PopStack(sStack)
If Left$(sStack, 1) = "*" Then
InfixToRPN = sStack
Exit Function
End If
ElseIf InStr("&/", sCur)<> 0 Then
sOutputString = sOutputString & PopStack(sStack)
If Left$(sStack, 1) = "*" Then
InfixToRPN = sStack
Exit Function
End If
sStack = sStack & sCur
End If
Next iPtr
sOutputString = sOutputString & PopStack(sStack)
InfixToRPN = sOutputString
End Function
Private Function PopStack(ByRef Stack As String) As String
Dim iLen As Integer
Dim sCur As String
PopStack = ""
Do
If Len(Stack) = 0 Then Exit Function
sCur = Right$(Stack, 1)
If sCur<> "(" Then PopStack = PopStack & sCur
iLen = Len(Stack)
If iLen > 1 Then
Stack = Left$(Stack, iLen - 1)
Else
Stack = ""
End If
Loop While sCur<> "("
End Function
Private Function EvaluateRPNExpression(ByVal RPNString As String) As Variant
'------------------------------------------------------------------------------------
'-- Evaluate RPN Expression. If evaluates to True, Return Result & exit --
'-- Evaluation rules taken from a web site:- --
'-- While there are input tokens left --
'-- Read the next token from input. --
'-- --
'-- If the token is a value --
'-- Push it onto the stack. --
'-- --
'-- Otherwise, the token is a function. --
'-- (Operators, like +, are simply functions taking two arguments.) --
'-- It is known that the function takes n arguments. --
'-- So, pop the top n values from the stack. --
'-- If there are fewer than n values on the stack --
'-- (Error) The user has not input sufficient values in the expression. --
'-- Evaluate the function, with the values as arguments. --
'-- Push the returned results, if any, back onto the stack. --
'-- --
'-- If there is only one value in the stack --
'-- That value is the result of the calculation. --
'-- If there are more values in the stack --
'-- (Error) The user input too many values. --
'------------------------------------------------------------------------------------
Dim bResult As Boolean
Dim iPtr As Integer, iLen As Integer
Dim sStack As String, sCur As String
Dim sToken1 As String, sToken2 As String
For iPtr = 1 To Len(RPNString)
'-- Get next token --
sCur = Mid$(RPNString, iPtr, 1)
'-- Test if True or False token --
If InStr("TF", sCur)<> 0 Then
sStack = sStack & sCur
Else
iLen = Len(sStack)
If iLen< 2 Then
'We have a problem!
EvaluateRPNExpression = "*** Illformed Expression ***"
Exit Function
End If
sToken2 = Right$(sStack, 1)
sStack = Left$(sStack, iLen - 1)
iLen = iLen - 1
sToken1 = Right$(sStack, 1)
If iLen > 1 Then
sStack = Left$(sStack, iLen - 1)
Else
sStack = ""
End If
If sCur = "/" Then
bResult = sToken1 = "T" Or sToken2 = "T"
Else
bResult = sToken1 = "T" And sToken2 = "T"
End If
If bResult Then
sStack = sStack & "T"
Else
sStack = sStack & "F"
End If
End If
Next iPtr
If Len(sStack)<> 1 Then
EvaluateRPNExpression = "*** Illformed Expression ***"
ElseIf sStack = "T" Then
EvaluateRPNExpression = True
Else
EvaluateRPNExpression = False
End If
End Function
> </o
