Macro para extraer los valores únicos en Excel

Código para Rango Fijo

Sub ValoresUnicos()

    Dim L As Range, U As Range, i As Long, j As Long, dict As Object

    Set L = Application.InputBox(Prompt:="Rango de datos:", Title:="IB", Type:=8)

    Set U = Application.InputBox(Prompt:="Celda destino:", Title:="IB", Type:=8)

    Set dict = CreateObject("Scripting.Dictionary")

    For i = 1 To L.Rows.count

        For j = 1 To L.Columns.count

            If Not dict.Exists(L(i, j).Value) Then

                dict.Add L(i, j).Value, 0

            End If

        Next j

    Next i

    U.Resize(dict.count, 1).Value = Application.Transpose(dict.Keys)

End Sub