'---------------------------------------------------------------------------------------
' Module    : DistinctListDataValidation
' Author    : Андрей Лящук aka krosav4ig http://www.excelworld.ru/index/8-krosav4ig
' Date      : 27.02.2019
' Purpose   : Генерация сортированного списка уникальных значений для проверки данных
'---------------------------------------------------------------------------------------
'---------------------------------------------------------------------------------------
' function  : DistinctValues
' Purpose   : Возвращает диапазон со списком уникальных значений
' Arguments : R1 - Верхняя ячейка диапазона с исходным списком
'             R2 - Верхняя ячейка диапазона, в который будет помещен список уникальных значений
'---------------------------------------------------------------------------------------
Function DistinctValues(R1 As Range, R2 As Range) As Range
    Dim sR1$, sR2$, sR3$
    If IsEmpty(R1) Then Exit Function
    With Application
        .Volatile True
        sR1 = R1.Address(, , .ReferenceStyle, 1)
        sR2 = R2.Address(, , .ReferenceStyle, 1)
        sR3 = .Caller.Address(, , .ReferenceStyle, 1)
        Evaluate "DistinctListDataValidation.PopulateRange(" & sR1 & "," & sR2 & "," & sR3 & ")"
        .ScreenUpdating = 0
        Set DistinctValues = ExtendDown(R2)
        DoEvents
        .ScreenUpdating = 1
    End With
End Function
'---------------------------------------------------------------------------------------
' Procedure : PopulateRange
' Purpose   : Заполняет диапазон сгенерированным списком уникальных значений
' Arguments : R1 - Верхняя ячейка диапазона с исходным списком
'             R2 - Верхняя ячейка диапазона, в который будет помещен список уникальных значений
'             R3 - Application.Caller, в текущем контексте - активная ячейка с выпадающим списком
'---------------------------------------------------------------------------------------
Private Sub PopulateRange(R1 As Range, R2 As Range, R3 As Range)
    Dim v As Variant
    With ExtendDown(R1)
        If .Cells.Count = 1 Then
            ExtendDown(R2).Value = Empty
            R2 = R1: Exit Sub
        End If
    End With
    With CreateObject("scripting.dictionary")
        For Each v In ExtendDown(R1).Value
            .Item(v) = ""
        Next
        v = BubbleSort(.keys())
        If R3.Value <> "" Then v = Filter(v, R3.Value, False)
    End With
    ExtendDown(R2).Value = Empty
    Application.EnableEvents = 0
    R2.Resize(UBound(v) + 1).Value = Application.Transpose(v)
    Application.EnableEvents = 1
End Sub
'---------------------------------------------------------------------------------------
' Function  : BubbleSort
' Purpose   : Возвращает массив, отсортированный пузырьковым алгоритмом
' Arguments : v - Исходный массив
'---------------------------------------------------------------------------------------
Private Function BubbleSort(v As Variant) As Variant
    Dim i&, j&
    For i = LBound(v) To UBound(v) - 1: For j = i To UBound(v)
        Swap v(i), v(j)
    Next j, i
    BubbleSort = v
End Function
Private Sub Swap(ByRef a As Variant, ByRef b As Variant)
    If a > b Then: Dim c: c = a: a = b: b = c
End Sub
'---------------------------------------------------------------------------------------
' Function  : ExtendDown
' Purpose   : Возвращает диапазон расширенный вниз до последней непустой ячейки
' Arguments : R - верхняя ячейка диапазона
'---------------------------------------------------------------------------------------
Private Function ExtendDown(r As Range) As Range
    If IsEmpty(r.Offset(1)) Then
        Set ExtendDown = r
    Else
        Set ExtendDown = r.Resize(r.End(xlDown).Row - r.Row + 1)
    End If
End Function