Extract Unique Values

Attribute VB_Name = "ExtractUniqueValues"
Option Explicit

Public Sub ExtractUniqueValues()
    Dim srcRange As Range
    Dim cell As Range
    Dim uniques As Object
    Dim destWs As Worksheet
    Dim k As Variant
    Dim r As Long

    Set srcRange = Selection
    Set uniques = CreateObject("Scripting.Dictionary")

    For Each cell In srcRange
        If Trim(cell.Value) <> "" Then
            uniques(CStr(cell.Value)) = True
        End If
    Next cell

    Set destWs = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
    destWs.Name = "UniqueValues"
    destWs.Range("A1").Value = "Unique Value"

    r = 2
    For Each k In uniques.Keys
        destWs.Cells(r, 1).Value = k
        r = r + 1
    Next k

    MsgBox uniques.Count & " unique value(s) extracted to '" & destWs.Name & "'.", vbInformation
End Sub