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?
If we can extract and get the count of this collection, then the problem is solved.
Please help.
Thanks in advance!
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:
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
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.
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
