• Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 2574
  • Last Modified:

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

0
ASUGlen
Asked:
ASUGlen
1 Solution
 
dlmilleCommented:
Why not just use a SQL statement to filter your collection?  You could write your collection to a worksheet, then query it back.
0
 
dlmilleCommented:
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)
0
 
aikimarkCommented:
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).
0
Industry Leaders: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

 
ASUGlenAuthor Commented:
Could you give an example of the Microsoft Scriplet library never used that before.
0
 
aikimarkCommented:
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

0
 
dlmilleCommented:
I love it when a plan comes together!

Dave
0
 
aikimarkCommented:
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

0
 
aikimarkCommented:
You can simplify the filter string, making it look like field references if you use a With...End With construct.

Option Explicit

Public Sub main()
    Dim colCC As New Collection
    Dim oCC As Class1
    Dim lngLoop As Long
    Dim oVBS As Object      'alternatively New ScriptControl if Reference added

    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 & _
                 "  With parmCC " & vbCrLf & _
                 "    CCFilter = (.Field1 = ""ABC"") AND (.Status >=2) " & vbCrLf & _
                 "  End With " & vbCrLf & _
                 "End function"
    
    For Each oCC In colCC
        lngLoop = lngLoop + 1
        If oVBS.Run("CCFilter", oCC) = True Then
            Debug.Print lngLoop, oCC.Status, oCC.Field1
        End If
    Next
    
    Set colCC = Nothing
End Sub

Open in new window


Notes:
* Since class properties are required to be properly formed names, you do not need the square brackets like you do with database fields that contain spaces.

* Now a property reference in the filter string only needs to be proceeded by a period:
(.Field1 = ""ABC"") AND (.Status >=2)

* If they square bracket the field names, the period still works:
(.[Field1] = ""ABC"") AND (.[Status] >=2)

* You could use some Replace() functions to convert your user's filter string.
Examples:
* your example filter
mainParm = "([Field1] = ""ABC"") AND ([Status] >=2)"
mainParm = Replace(mainParm, "[", ".[")

* If the user already has supplied a . prefix to one or more fields.
mainParm = "(.[Field1] = ""ABC"") AND ([Status] >=2)"
mainParm = Replace(Replace(mainParm, "[", ".["), "..[", ".[")

* Since I'm only printing those items that meet the filter criteria, I simplified the code and removed the varItem variable use.  It would always be True.

* You could use the FastConcatenate function I described in this article when constructing the lines of your ScriptControl code.  You would set vbCrlf as the delimiter property before accessing the Text property.  I realize that this filter is a small chunk of code, but you might need to do something else with the scriptcontrol code that would greatly increase its size.
http:/A_8311.html
    Dim BS As New clsBuildString

    BS.Add "Function CCFilter(parmCC) "
    BS.Add "  With parmCC " 
    BS.Add "    CCFilter = (.Field1 = ""ABC"") AND (.Status >=2) "
    BS.Add "  End With "
    BS.Add "End function"    
    BS.Delim = vbCrLf
    oVBS.AddCode BS.Text
 

Open in new window

0
 
aikimarkCommented:
I've started writing an article on the use of the ScriptControl class for filtering.
0
 
aikimarkCommented:
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.
0
 
aikimarkCommented:
Please read my new article:
http://www.experts-exchange.com/A_8450.html
0
 
Martin LissRetired ProgrammerCommented:
This question has been classified as abandoned and is closed as part of the Cleanup Program. See the recommendation for more details.
0

Featured Post

[Webinar] Database Backup and Recovery

Does your company store data on premises, off site, in the cloud, or a combination of these? If you answered “yes”, you need a data backup recovery plan that fits each and every platform. Watch now as as Percona teaches us how to build agile data backup recovery plan.

Tackle projects and never again get stuck behind a technical roadblock.
Join Now