Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Уникальные значения в выпадающем списке ячейки - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: _Boroda_, китин  
Мир MS Excel » Вопросы и решения » Готовые решения » Уникальные значения в выпадающем списке ячейки (Excel)
Уникальные значения в выпадающем списке ячейки
krosav4ig Дата: Среда, 27.02.2019, 13:21 | Сообщение № 1
Группа: Друзья
Ранг: Старожил
Сообщений: 2346
Репутация: 989 ±
Замечаний: 0% ±

Excel 2007,2010,2013
Всем привет! Набросал я тут код для формирования сортированного списка уникальных значений для проверки данных, в планах по такому же принципу реализовать каскадные выпадающие списки, но как-то времени все нет.

В диспетчере имен формулы типа
Код
=DistinctValues(ВерхняяЯчейкаИсходногоСписка;ВерхняяЯчейкаПолученногоСписка)
Проверка данных ссылается на эти имена. Тестировал в версиях Excel с 2003 по 2013, во всех работает.

UPD.
Убрал лишнюю строку и массив из процедуры PopulateRange
К сообщению приложен файл: DistinctListDat.xlsm (23.8 Kb)


email:krosav4ig26@gmail.com WMR R207627035142 WMZ Z821145374535 ЯД 410012026478460

Сообщение отредактировал krosav4ig - Среда, 27.02.2019, 14:17
 
Ответить
СообщениеВсем привет! Набросал я тут код для формирования сортированного списка уникальных значений для проверки данных, в планах по такому же принципу реализовать каскадные выпадающие списки, но как-то времени все нет.

В диспетчере имен формулы типа
Код
=DistinctValues(ВерхняяЯчейкаИсходногоСписка;ВерхняяЯчейкаПолученногоСписка)
Проверка данных ссылается на эти имена. Тестировал в версиях Excel с 2003 по 2013, во всех работает.

UPD.
Убрал лишнюю строку и массив из процедуры PopulateRange

Автор - krosav4ig
Дата добавления - 27.02.2019 в 13:21
Anchoret Дата: Пятница, 15.03.2019, 20:30 | Сообщение № 2
Группа: Пользователи
Ранг: Прохожий
Сообщений: 9
Репутация: 0 ±
Замечаний: 0% ±

Excel 2016
Возможно пригодится:
[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
[/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
[/vba]

Автор - Anchoret
Дата добавления - 15.03.2019 в 20:30
Мир MS Excel » Вопросы и решения » Готовые решения » Уникальные значения в выпадающем списке ячейки (Excel)
  • Страница 1 из 1
  • 1
Поиск:

Яндекс.Метрика Яндекс цитирования
© 2010-2024 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!