Link to home
Start Free TrialLog in
Avatar of ASUGlen
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

Open in new window

Avatar of dlmille
dlmille
Flag of United States of America image

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)
Avatar of aikimark
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).
Avatar of ASUGlen
ASUGlen

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.
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

Open in new window


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

Open in new window

I love it when a plan comes together!

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

Open in new window

ASKER CERTIFIED SOLUTION
Avatar of aikimark
aikimark
Flag of United States of America image

Link to home
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
Start Free Trial
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.
This question has been classified as abandoned and is closed as part of the Cleanup Program. See the recommendation for more details.