Option Explicit
Option Base 1

Sub Rio_Sort()

'Author:    Roman Rioran Voronov
'Date:      the 14-th of October, 2014
'Feedback:  voronov_rv@mail.ru

'    Макрос предлагает выбрать диапазон ячеек, из значений которых создаст отсортированный список
'без дубликатов. Пустые ячейки и ячейки с пробелом игнорируются. В конце макрос прелагает выбрать
'диапазон, в первую ячейку которого итоговый список будет вставлен.

'    This subroutine allows User to select range, from where sorted list of values will be recei-
'ved. Doublicates, empty cells and cells with a single space value will be ignored. As conclusion
'User have to select cell, where final list will be pasted.

Dim rngA As Range, rngX As Range 'To fill arrX with values
Dim arrX, ValueX As String 'For sorting values
Dim arrY, ValueY As Long 'For final results
Dim A, B As Long 'For bubble sorting and selection
Dim X As Long 'rngA.count
Dim Ring As Long 'How deep our circle is
Dim Permission As Byte 'If 0 then exit Do

Set rngA = Application.InputBox(Prompt:="Выберите диапазон, который будет отсортирован без дубликатов.", Title:="Range Select", Type:=8)

ReDim arrX(rngA.Count + 1, 1)
ReDim arrY(rngA.Count + 1, 1)

For Each rngX In rngA
       X = X + 1
       arrX(X, 1) = CStr(rngX.Value)
Next rngX

Set rngA = Nothing: Set rngX = Nothing

For A = 1 To X
       For B = 1 To X + 1 - A
           Permission = 1
           Ring = 1
           If arrX(B, 1) = "" Then arrX(B, 1) = " "
           If arrX(B, 1) <> arrX(B + 1, 1) Then
               Do While Permission = 1
                   If Ring > Application.Min(Len(arrX(B, 1)), Len(arrX(B + 1, 1))) Then Exit Do
                   If Asc(Mid(arrX(B, 1), Ring, 1)) > Asc(Mid(arrX(B + 1, 1), Ring, 1)) Then
                       ValueX = arrX(B, 1)
                       arrX(B, 1) = arrX(B + 1, 1)
                       arrX(B + 1, 1) = ValueX
                       Permission = 0
                   ElseIf Asc(Mid(arrX(B, 1), Ring, 1)) = Asc(Mid(arrX(B + 1, 1), Ring, 1)) Then
                       Ring = Ring + 1
                   Else
                       Exit Do
                   End If
               Loop
           End If
       Next B
Next A

B = 1
For A = 1 To X - 1
       If arrX(A, 1) <> arrX(A + 1, 1) Then
           If arrX(A, 1) <> " " Then
               arrY(B, 1) = arrX(A, 1)
               B = B + 1
           End If
       End If
Next A

arrY(B, 1) = arrX(X, 1)

Set rngA = Application.InputBox(Prompt:="Выберите, куда вставить итоговый список.", Title:="Range Select", Type:=8)

rngA.Cells(1, 1).Resize(X, 1).Value = arrY

End Sub