Extracting the collection of unique values from a filter in VBA

Question

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

Answer 1

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

Answer 2

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:

        

Answer 3

Yes, Data tab >> remove duplicates

Answer 4

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

Answer 5

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.