Всем привет! Набросал я тут код для формирования сортированного списка уникальных значений для проверки данных, в планах по такому же принципу реализовать каскадные выпадающие списки, но как-то времени все нет.
[vba]
Код
'--------------------------------------------------------------------------------------- ' 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
Проверка данных ссылается на эти имена. Тестировал в версиях Excel с 2003 по 2013, во всех работает.
UPD. Убрал лишнюю строку и массив из процедуры PopulateRange
Всем привет! Набросал я тут код для формирования сортированного списка уникальных значений для проверки данных, в планах по такому же принципу реализовать каскадные выпадающие списки, но как-то времени все нет.
[vba]
Код
'--------------------------------------------------------------------------------------- ' 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
Sub UniList(arr(), dd, Optional S As Boolean = True) Dim a&, b&, c& If UBound(arr) + 1 - LBound(arr) + 1 > 1 Then If S Then QuickSort arr(), LBound(arr), UBound(arr) c = LBound(arr): b = 1 For a = LBound(arr) + 1 To UBound(arr) If arr(a) > arr(c) Then b = b + 1: c = a Next If arr(a - 1) > arr(c) Then b = b + 1 Else: ReDim dd(1 To 1): dd(1) = arr(LBound(arr)): Exit Sub End If ReDim dd(1 To b): b = 1: c = LBound(arr): dd(b) = arr(c) For a = LBound(arr) + 1 To UBound(arr) If arr(a) > arr(c) Then b = b + 1: c = a: dd(b) = arr(c) Next If arr(a - 1) > arr(c) Then b = b + 1: dd(b) = arr(a - 1) End Sub '------QSort-------- Sub QuickSort(a(), ByVal L&, ByVal U&) Dim I&, J&, y, x I = L: J = U: x = a((L + U) \ 2) Do Do While a(I) < x: I = I + 1: Loop Do While x < a(J): J = J - 1: Loop 'a->c If I <= J Then y = a(I): a(I) = a(J): a(J) = y: I = I + 1: J = J - 1 End If Loop Until I > J If L < J Then QuickSort a(), L, J If I < U Then QuickSort a(), I, U End Sub
[/vba]
Возможно пригодится: [vba]
Код
Sub UniList(arr(), dd, Optional S As Boolean = True) Dim a&, b&, c& If UBound(arr) + 1 - LBound(arr) + 1 > 1 Then If S Then QuickSort arr(), LBound(arr), UBound(arr) c = LBound(arr): b = 1 For a = LBound(arr) + 1 To UBound(arr) If arr(a) > arr(c) Then b = b + 1: c = a Next If arr(a - 1) > arr(c) Then b = b + 1 Else: ReDim dd(1 To 1): dd(1) = arr(LBound(arr)): Exit Sub End If ReDim dd(1 To b): b = 1: c = LBound(arr): dd(b) = arr(c) For a = LBound(arr) + 1 To UBound(arr) If arr(a) > arr(c) Then b = b + 1: c = a: dd(b) = arr(c) Next If arr(a - 1) > arr(c) Then b = b + 1: dd(b) = arr(a - 1) End Sub '------QSort-------- Sub QuickSort(a(), ByVal L&, ByVal U&) Dim I&, J&, y, x I = L: J = U: x = a((L + U) \ 2) Do Do While a(I) < x: I = I + 1: Loop Do While x < a(J): J = J - 1: Loop 'a->c If I <= J Then y = a(I): a(I) = a(J): a(J) = y: I = I + 1: J = J - 1 End If Loop Until I > J If L < J Then QuickSort a(), L, J If I < U Then QuickSort a(), I, U End Sub