Sub cMethodAdvFilter()
    CountUniqueByAdvFilter Selection.Address
End Sub

Sub CountUniqueByAdvFilter(mRange As String)
    Dim TheRange As String
    Application.ScreenUpdating = False
    
    TheRange = "'[" & ActiveWorkbook.Name & _
    "]" & ActiveSheet.Name & "'!" & mRange
    
    Workbooks.Add
    
    Range(TheRange).AdvancedFilter Action:=xlFilterCopy, CopyToRange _
	:=Range("A1"), Unique:=True
    
    MsgBox Application.WorksheetFunction.CountA(Range("A:A"))
    
    ActiveWorkbook.Close False
    
    Application.ScreenUpdating = True
End Sub

 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

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

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