CODEWITHSUNDEEP
vbaexcel
Matan P
Matan P

Reputation: 37

Using VBA to Read AutoFilter Criteria

I am working with an excel workbook where I want to find all unique values in a column.

I have code that works by looping through all the rows and for each row looping through a collection of values seen so far and checking if I've seen it before.

It works like this. 

Function getUnique(Optional col As Integer) As Collection
    If col = 0 Then col = 2
    Dim values As Collection
    Dim value As Variant
    Dim i As Integer
    Dim toAdd As Boolean
    
    i = 3 'first row with data
    Set values = New Collection
    
    Do While Cells(i, col) <> ""
        toAdd = True
        For Each value In values
            If Cells(i, col).value = value Then toAdd = False
        Next value
        If toAdd Then values.Add (Cells(i, col).value)
        i = i + 1
    Loop
    
    Set getUnique = values
        
End Function

However, Excel AutoFilter is able to find these values much faster. Is there a way to filter and then read the unique values?

I've tried using the AutoFilter.Filters object but all of the .ItemX.Criteria1 values have a "Application-defined or object-defined error" (found using a watch on ActiveSheet.AutoFilter.Filters).

Upvotes: 0

Views: 1654

Answers (2)

Scott Holtzman
Scott Holtzman

Reputation: 27239

The AdvancedFilter method may come in handy here and produce cleaner, easier to maintain code. This will work so long as you are calling this Function from another VBA module and not from a cell.

Function getUnique(Optional col As Integer) As Collection

    If col = 0 Then col = 2

    Dim values As Collection
    Dim value As Variant
    Dim i As Integer

    i = 3 'first row with data

    Range(Cells(i, col), Cells(Rows.Count, col).End(xlUp)).AdvancedFilter xlFilterCopy, CopyToRange:=Cells(1, Columns.Count)

    Set values = New Collection

    Dim cel As Range
    For Each cel In Range(Cells(1, Columns.Count), Cells(1, Columns.Count).End(xlDown))
        values.Add cel.value
    Next

    Range(Cells(2, Columns.Count), Cells(1, Columns.Count).End(xlDown)).Clear

    Set getUnique = values

End Function

Tested with this sub:

Sub Test()

Dim c As Collection
Set c = getUnique(4)

For i = 1 To c.Count
    Debug.Print c.Item(i)
Next


End Sub

Upvotes: 0

David Zemens
David Zemens

Reputation: 53623

This isn't quite doing what you describe, I think it's processing it less-efficiently because it's checking every cell against every value.

I think this is probably inefficient, because as the values collection grows in length, the second loop will take longer to process.

You could get some improvement if you exit your nested For early:

    Do While Cells(i, col) <> ""
        For Each value In values
            If Cells(i, col).value = value Then 
                toAdd = False
            Else:
                values.Add (Cells(i, col).value) 
                Exit For  '### If the value is found, there's no use in checking the rest of the values!
            End If
        Next value
        i = i + 1
    Loop

But I think a Dictionary may give you performance improvement. This way, we don't need to loop over the collection, we just make use of the dictionary's .Exists method. If it doesn't exist, we add to the collection, if it does, we don't. Then the function still returns the collection of uniques.

Function getUnique(Optional col As Integer) As Collection
    If col = 0 Then col = 2
    Dim values As Object
    Dim value As Variant
    Dim i As Integer
    Dim toAdd As Boolean
    Dim ret as New Collection

    i = 3 'first row with data
    Set values = CreateObject("Scripting.Dictionary")

    With Cells(i, col)
    Do While .Value <> ""
        If Not values.Exists(.Value) 
            values(.Value) = 1
            ret.Add(.Value)   '## Add the item to your collection
        Else
            '## Count the occurences, in case you need to use this later
            values(.Value) = values(.Value) + 1

        End If
        i = i + 1
    Loop

    Set getUnique = ret

End Function

Upvotes: 1

Related Questions