CODEWITHSUNDEEP
vbaexcelfilterwith-statement
Soham
Soham

Reputation: 873

Extracting the collection of unique values from a filter in VBA

I have a file which has rows extending to tens of thousands across 8 columns. One particular column contains the weekend date. I have to count the number of weekends present in this file.

Is there a way to extract the data as shown in the image below?

enter image description here

If we can extract and get the count of this collection, then the problem is solved.

Please help.

Thanks in advance!

Upvotes: 5

Views: 10192

Answers (5)

Zev Spitz
Zev Spitz

Reputation: 15317

You could connect to the appropriate worksheet using ADODB, and issue an SQL statement against the worksheet:

Dim datasourcePath As String
datasourcePath = "C:\path\to\excel\file.xlsx"

Dim connectionString As String
connectionString = _
    "Provider=Microsoft.ACE.OLEDB.12.0;" & _
    "Data Source=""" & datasourcePath & """;" & _
    "Extended Properties=""Excel 12.0;HDR=No""

Dim sql As String
sql = "SELECT DISTINCT F1 FROM [Sheet1$]" 'F1 is an autogenerated field name

Dim rs As New ADODB.Recordset
rs.Open sql, connectionString

Do Until rs.EOF
    Debug.Print rs("F1")
Loop

Upvotes: 0

Gabriel G
Gabriel G

Reputation: 700

Yes, Data tab >> remove duplicates

Upvotes: 0

gembird
gembird

Reputation: 14053

To get the unique values from a column like in the filter dialog you could use Range.RemoveDuplicates method.

Example:

' Index of Column which contains the weekend date
Const weekendDateColumn As Integer = 2

Sub GetUniques()
    ' Create copy of active sheet with data so original data remains unchanged
    ActiveSheet.Copy After:=ActiveSheet

    ' Call Range.RemoveDuplicates method which removes duplicates in 
    ' data besed on values in column 'weekendDateColumn'
    Dim data As Range
    Set data = ActiveSheet.Range("A1").CurrentRegion
    data.RemoveDuplicates Columns:=Array(weekendDateColumn), Header:=xlYes

    ' Get unique values into array
    Dim uniques As Variant
    uniques = data.CurrentRegion.Columns(weekendDateColumn).Value

    ' Clear data resize it to size of uniques and paste the uniques there
    data.Clear
    data.Resize(UBound(uniques, 1), 1).Value = uniques
End Sub

Upvotes: 2

Ashwith Ullal
Ashwith Ullal

Reputation: 263

Select the range of cells, or make sure the active cell is in a table.

On the Data tab, in the Sort & Filter group, click Advanced.

The Sort & Filter group on the Data tab

In the Advanced Filter dialog box, do one of the following:

To filter the range of cells or table in place, click Filter the list, in-place.

To copy the results of the filter to another location, do the following:

Click Copy to another location.

In the Copy to box, enter a cell reference.

Alternatively, click Collapse Dialog Button image to temporarily hide the dialog box, select a cell on the worksheet, and then press Expand Dialog Button image.

Select the Unique records only check box, and click OK.

The unique values from the selected range are copied to the new location.

Upvotes: 1

user4039065
user4039065

Reputation:

The following will take a series of three randomized upper-case letters from column A (25K values), put them into a dictionary as unique keys (13,382 values) and dump them back into column C on the same worksheet before sorting them. The round trip takes ~0.072 seconds.

The following code requires that you go into the VBE's Tools ► References and add Microsoft Scripting Runtime. This holds the library definitions for a Scripting.Dictionary. However, if you use CreateObject("Scripting.Dictionary"), you do not require the library reference.

Sub buildFilterList()
    Dim dMUSKMELONs As Object    'New Scripting.Dictionary
    Dim v As Long, w As Long, vTMPs As Variant

    Debug.Print Timer
    Set dMUSKMELONs = CreateObject("Scripting.Dictionary")

    With Worksheets("Sheet2")   '<-set this worksheet reference properly!
        vTMPs = .Range(.Cells(2, "A"), .Cells(Rows.Count, "A").End(xlUp)).Value2
        For v = LBound(vTMPs, 1) To UBound(vTMPs, 1)
            If Not dMUSKMELONs.Exists(vTMPs(v, 1)) Then _
                dMUSKMELONs.Add key:=vTMPs(v, 1), Item:=vbNullString
        Next v
        With .Cells(2, "C").Resize(dMUSKMELONs.Count, 1)
            .Value = Application.Transpose(dMUSKMELONs.Keys)
            .Cells.Sort Key1:=.Columns(1), Order1:=xlAscending, _
                        Orientation:=xlTopToBottom, Header:=xlNo
        End With
        .Cells(2, "D") = dMUSKMELONs.Count
    End With

    dMUSKMELONs.RemoveAll
    Set dMUSKMELONs = Nothing

    Debug.Print Timer

End Sub

Results should be similar to this:

        Filter List Values Unique and sorted

Upvotes: 6

Related Questions