ASUGlen
asked on
Create a Filter on a custom Collection VBA
I have created a custom function to filter a collection of objects. I'm using there property names to filter on. The filter string itself is simular to a SQL where statement Example ([Field1] = "ABC") AND ([Status] >=2) Would be a working example of the string to pass to filter the collection. But My issue is that I don't know how I should go about allowing the use of an OR Operand. Since I would almost have to stack the results for each OR in the filter statement. I have attached my function and any help or pointers in the right direction would be greatful
Function Filter_Collection(col As Collection, FilterOn, Optional KeyProperty As String) As Collection
'***Parameters
'col your collection of objects
'FilterOn a string containing your filters Simular syntax to a SQL Where Statement
'KeyProperty a unique Key for the new collection using one of the objects properties to populate
Dim aryFields() As String
Dim aryValues() As String
Dim aryOperands() As String
Dim aryOpTypes(6) As String
Dim aryFilters As Variant
Dim i As Integer, j As Integer
Dim colFlt As New Collection
Dim oObj As Object
Dim objIdx As Long
Dim testValue As String
aryOpTypes(0) = "<>"
aryOpTypes(1) = ">="
aryOpTypes(2) = "<="
aryOpTypes(3) = ">"
aryOpTypes(4) = "<"
aryOpTypes(5) = "="
aryOpTypes(6) = "LIKE"
aryFilters = Split(FilterOn, "AND")
ReDim aryFields(UBound(aryFilters))
ReDim aryValues(UBound(aryFilters))
ReDim aryOperands(UBound(aryFilters))
For i = 0 To UBound(aryFilters)
For j = 0 To UBound(aryOpTypes)
If InStr(aryFilters(i), UCase(aryOpTypes(j))) > 0 Then
aryFieldsk(i) = Left(aryFilters(i), InStr(1, aryFilters(i), aryOpTypes(j)) - 1)
aryValues(i) = Mid(aryFilters(i), InStr(1, aryFilters(i), aryOpTypes(j)) + Len(aryOpTypes(j)))
aryOperands(i) = aryOpTypes(j)
'***Clean up String***
aryFields(i) = Replace(aryFields(i), "(", "")
aryFields(i) = Replace(aryFields(i), "[", "")
aryFields(i) = Replace(aryFields(i), "]", "")
aryFields(i) = Trim(aryFields(i))
aryValues(i) = Replace(aryValues(i), """", "")
aryValues(i) = Replace(aryValues(i), ")", "")
aryValues(i) = Trim(aryValues(i))
j = UBound(aryOpTypes)
End If
Next j
Next
'***Prints Out the Parced Filters***
'For i = 0 To UBound(aryFilters)
' Debug.Print aryFields(i) & " " & aryOperands(i) & " " & aryValues(i) & " "
'Next i
'***Creates a new collection to filter
For Each oObj In col
If Not IsMissing(KeyProperty) And KeyProperty <> "" Then
colFlt.Add oObj, CallByName(oObj, KeyProperty, VbGet)
Else
colFlt.Add oObj
End If
Next
For i = 0 To UBound(aryFields)
objIdx = 1
For Each oObj In colFlt
'***Calls the Property and assigns it to the testValue***
testValue = CallByName(oObj, aryFields(i), VbGet)
'***Reverses the operand for comparison if no match it removes the object from the collection
If aryOperands(i) = "=" And testValue <> aryValues(i) Or _
aryOperands(i) = "<>" And testValue = aryValues(i) Or _
aryOperands(i) = ">=" And testValue < aryValues(i) Or _
aryOperands(i) = "<=" And testValue > aryValues(i) Or _
aryOperands(i) = ">" And testValue <= aryValues(i) Or _
aryOperands(i) = "<" And testValue >= aryValues(i) Or _
aryOperands(i) = "LIKE" And Not testValue Like aryValues(i) Then
colFlt.Remove objIdx
objIdx = objIdx - 1
End If
objIdx = objIdx + 1
Next
Next i
'***Returns the filtered Collection***
Set Filter_Collection = colFlt
End Function
Why not just use a SQL statement to filter your collection? You could write your collection to a worksheet, then query it back.
Sorry for asking dumb questions, but if you've got AND down pat, how about NOT?
A or B is equivalent to NOT A and NOT B
So:
A=x AND (B=y OR C=z) could be evaluated as
A=x AND NOT(B=y AND C=z)
A or B is equivalent to NOT A and NOT B
So:
A=x AND (B=y OR C=z) could be evaluated as
A=x AND NOT(B=y AND C=z)
If you use instantiate an ADO recordset, you don't even need to tie it to any physical medium or application, such as Access or Excel. You can define the recordset fields the same as your custom class properties. Then, similar to the earlier dmille comment, use the filter string directly against the recordset. You could have an autonumber field that would indicate which of your objects met the filter criteria (by item number).
Alternatively, you might create an on-the-fly VB routine that would implement the selection criteria. That would leverage the Microsoft Scriplet library (added reference needed).
Alternatively, you might create an on-the-fly VB routine that would implement the selection criteria. That would leverage the Microsoft Scriplet library (added reference needed).
ASKER
Could you give an example of the Microsoft Scriplet library never used that before.
Here is an example. If you want to play with this, you will want to add a Microsoft Scriptcontrol reference to your code.
Here is my Class1 class I created for testing purposes. For convenience, I added a boolSelected property.
I used your selection criteria, prefixing the field references with "varitem."
Here is my Class1 class I created for testing purposes. For convenience, I added a boolSelected property.
Option Explicit
Public Field1 As String
Public Status As Long
Public boolSelected As Boolean
Private Sub Class_Initialize()
Field1 = Chr(Int(Rnd * 3) + 65) & Chr(Int(Rnd * 3) + 65) & Chr(Int(Rnd * 3) + 65)
Status = Int(Rnd * 6)
End Sub
I used your selection criteria, prefixing the field references with "varitem."
Option Explicit
Public Sub main()
Dim colCC As New Collection
Dim oCC As Class1
Dim lngLoop As Long
Dim oVBS As Object 'New ScriptControl '-- requires reference
Dim varItem As Variant
Set oVBS = CreateObject("ScriptControl")
For lngLoop = 1 To 40
Set oCC = New Class1
colCC.Add oCC
Next
oVBS.Language = "VBScript"
oVBS.AddCode "sub colFilter( ) " & vbCrLf & _
"Dim varItem " & vbCrLf & _
"For Each varItem in parmCol " & vbCrLf & _
" varitem.boolSelected = (varitem.[Field1] = ""ABC"") AND (varitem.[Status] >=2) " & vbCrLf & _
"Next " & vbCrLf & _
"End sub"
oVBS.AddObject "parmCol", colCC
oVBS.Run "colFilter"
lngLoop = 0
For Each oCC In colCC
lngLoop = lngLoop + 1
If oCC.boolSelected Then
Debug.Print lngLoop, oCC.Status, oCC.boolSelected, oCC.Field1
End If
Next
Set colCC = Nothing
End Sub
I love it when a plan comes together!
Dave
Dave
I simplified the interpreted code from my prior comment. I return a true/false value from a function, rather than updating items in the collection. The iteration of the collection is now done in the main routine.
Option Explicit
Public Sub main()
Dim colCC As New Collection
Dim oCC As Class1
Dim lngLoop As Long
Dim oVBS As New ScriptControl 'Object '
Dim varItem As Variant
Set oVBS = CreateObject("ScriptControl")
For lngLoop = 1 To 40
Set oCC = New Class1
colCC.Add oCC
Next
oVBS.Language = "VBScript"
oVBS.AddCode "function CCFilter(parmCC) " & vbCrLf & _
" CCFilter = (parmCC.[Field1] = ""ABC"") AND (parmCC.[Status] >=2) " & vbCrLf & _
"End function"
For Each oCC In colCC
lngLoop = lngLoop + 1
varItem = oVBS.Run("CCFilter", oCC)
If varItem = True Then
Debug.Print lngLoop, varItem, oCC.Status, oCC.Field1
End If
Next
Set colCC = Nothing
End Sub
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
I've started writing an article on the use of the ScriptControl class for filtering.
The article code does implement a string pattern matching function.
Note: the automatic prepending of a period before every square bracket can't be used when doing string pattern matching, since square brackets are an integral part of such patterns.
Note: the automatic prepending of a period before every square bracket can't be used when doing string pattern matching, since square brackets are an integral part of such patterns.
Please read my new article:
https://www.experts-exchange.com/A_8450.html
https://www.experts-exchange.com/A_8450.html
This question has been classified as abandoned and is closed as part of the Cleanup Program. See the recommendation for more details.