Advanced Techniques


    Sub cMethodDAO() 
    Dim strDBFullName As String
    Dim dbData As Database, rstWork As Recordset, strSQL As String

    strDBFullName = ThisWorkbook.Path & "\" & ThisWorkbook.Name

    strSQL = "select distinct [your_field] from dataarea"
    
'Appropriate driver needed for this statement

    Set dbData = OpenDatabase(strDBFullName, False, True, _
Excel8.0;HDR=YES;)

    Set rstWork = dbData.OpenRecordset(strSQL)

    rstWork.MoveLast
   
    MsgBox rstWork.RecordCount

    Set rstWork = Nothing
    Set dbData = Nothing
    End Sub

where [your_field] is the header of the column you are interested in and
the dataarea is a named area that contains all data in question (could be
the single column you are interested in).


Sub CountUniqueByPivotTable() 

    On Error GoTo uOut

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    TheHeader = ActiveCell.Value

    ActiveSheet.PivotTableWizard SourceType:=xlDatabase, _
    SourceData:=ActiveSheet.Name & "!" & _
    Selection.Address, TableDestination:="", TableName:="uPivotTable"
 
    ActiveSheet.PivotTables("uPivotTable").AddFields RowFields:=TheHeader

    ActiveSheet.PivotTables("uPivotTable").PivotFields(TheHeader). _
    Orientation = xlDataField

    MsgBox Application.WorksheetFunction.CountA(Range("a:a")) - 3

    ActiveSheet.Delete

    Application.ScreenUpdating = True
    Application.DisplayAlerts = True

    Exit Sub
uOut:
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub


Although not tested extensively, it appears that the procedure that uses the Collection object produces the fastest result.

Sub cMethodByCollection() 
    CountUniqueByCollection Selection.Address
End Sub

Sub CountUniqueByCollection(AllCells As String)
    Dim NoDupes As New Collection
    On Error Resume Next

    For Each Cell In Range(AllCells)

        NoDupes.Add Cell.Value, CStr(Cell.Value)

'Note: the 2nd argument (key) for the Add method must be a string

    Next Cell
    On Error GoTo 0
End Sub


© 2020 Better Solutions Limited. All Rights Reserved. © 2020 Better Solutions Limited TopPrev