Выпадающий список с добавлением новых элементов

Предположим, что у нас есть справочник с именами сотрудников и таблица, куда этих сотрудников нужно вносить:

Исходные данные

Задача состоит из двух частей:

  • Сделать выпадающий список, причем так, чтобы при дописывании новых людей к справочнику - они автоматически появлялись и в выпадающем списке.
  • Реализовать возможность добавления новых людей в список и с другой стороны - при вводе нового имени в любую из жёлтых ячеек оно должно автоматически добавляться к справочнику (и в выпадающий список в будущем, само-собой).

Такая вот двухсторонняя связь справочника и выпадающего списка.

Шаг 1. Создаем умную таблицу

Сначала превратим справочник в "умную" таблицу, чтобы воспользоваться одним из главных её преимуществ - динамической автоподстройкой размеров при добавлении новых данных.

Для этого выделим весь справочник (ячейки A1:A7) и нажмём сочетание клавиш Ctrl+T или выберем Главная - Форматировать как таблицу (Home - Format as Table). В следующем окне можно смело жать ОК:

Создаем умную таблицу

Шаг 2. Создаем динамический именованный диапазон

Теперь создадим именованный диапазон, указывающий на заполненные именами ячейки в нашем справочнике. Для этого выделим в справочнике уже только имена без шапки (ячейки A2:A7) и в левой части строки формул (там будет имя таблицы) введём имя для нашего диапазона (например Люди):

Создаем резиновый именованный диапазон

После ввода имени обязательно нужно нажать на клавишу Enter - слово Люди исчезнет из этого поля, но диапазон будет создан.

Хитрость тут в том, что поскольку мы выделяли столбец уже в "умной" таблице, то и именованный диапазон у нас получился завязанным на колонку [Справочник], а не на конкретные выделенные ячейки. Убедиться в этом можно, если выбрать на вкладке Формулы команду Диспетчер имен (Formulas - Name Manager) и посмотреть куда ссылается имя Люди:

Диспетчер имен

Таким образом, при дописывании новых имен к справочнику будет расширяться наша "умная" Таблица1, а за ней и наш именованный диапазон Люди.

Шаг 3. Создаем выпадающий список в ячейке

Выделяем жёлтые ячейки и жмем на вкладке Данные (Data) кнопку Проверка данных (Data Validation) 

Далее выбираем из выпадающего списка Тип данных (Allow) позицию Список (List) и вводим в строку Источник (Source) ссылку на созданный на шаге 1 именованный диапазон (не забудьте перед именем диапазона поставить знак равенства!):

Создаем выпадающий список

Чтобы Excel позволил нам в будущем ввести в список и новые имена, снимем галочки на вкладках Сообщение для ввода (Input Message) и Сообщение об ошибке (Error Alert) и нажмем ОК. Выпадающий список готов!

Причем, если, например, вручную дописать новое имя в справочник в столбце А, то оно автоматически появится в выпадающем списке в любой из жёлтых ячеек, поскольку имена берутся из динамического диапазона Люди:

Пополняем справочник

Шаг 4. Добавляем простой макрос

Теперь вставим в нашу книгу простой макрос, который будет отслеживать ввод в жёлтые ячейки и при вводе незнакомых людей добавлять их справочнику.

Щёлкаем правой кнопкой мыши по ярлычку нашего листа и выбираем Просмотреть код (View Source). Откроется модуль листа в редакторе Visual Basic, куда надо скопировать такой код:

Private Sub Worksheet_Change(ByVal Target As Range)
    Set p = Range("Люди")
    If Target.Cells.Count > 1 Then Exit Sub
    If IsEmpty(Target) Then Exit Sub
    If Not Intersect(Target, Range("D2:D10")) Is Nothing Then
        If WorksheetFunction.CountIf(p, Target) = 0 Then
            r = MsgBox("Добавить новое имя в справочник?", vbYesNo)
            If r = vbYes Then p.Cells(p.Rows.Count + 1) = Target
        End If
    End If
End Sub

Теперь при попытке ввести новое имя в любую из жёлтых ячеек Excel будет спрашивать:

Вопрос о добавлении

... и при утвердительном ответе пользователя автоматически добавлять новое имя к справочнику и в выпадающий список в дальнейшем.

Ссылки по теме


Страницы: 1  2  3  
Александр
03.10.2012 19:54:27
Сортировать бы еще список по алфавиту после каждого добавления...
06.10.2012 17:47:24
Да, мысль хорошая, подумаем :)
Александр
03.10.2012 19:55:54
Очень полезный ресурс вы создали. Очень много интересного и нового.
Ну вот и у меня возник вопрос, причем достаточно срочный, спасайте: в данном примере (описаном выше) в качестве ячейки для выбора/ввода нового значения - указана одна ячейка. Как сделать так, чтобы при вводе данных в диапазон, к примеру, D2:D10, в любую из этих ячеек, происходила проверка и добавление в список. Прописать в стоорке If Target.Adress= и так далее 10 раз, можно через or, но мне нужен диапазон в 4000 строк :-). Помогите пожалуйста!!!
18.01.2013 12:59:56
Александр, проблема видимо в строчке (If Target.Cells.Count > 1 Then Exit Sub).
Пробовала вводить диапазон ячеек, сохраняю изменения, но при вводе информации в ячейку, Эксель не предлагает добавить ее в список.
Изменение параметра Target.Cells.Count тоже ни к чему не приводит.
У кого-нибудь есть идеи?
Роман
03.10.2012 19:56:27
 Офигеть!!! Даже я всё понял. Круто!!!
Роман
03.10.2012 19:57:17
Супер сайт.
В этом примере небольшая ошибка, в английской версии формулы стоят запятые, а нужны точки с запятой. Иначе эксель ругается:).
06.10.2012 17:44:11
Спасибо, подправил.
сан
03.10.2012 19:57:44
Спасибо за помощь,я ищу возможность делать при помощи табл Excel можно делать сметы калькуляции.
Мария
03.10.2012 20:03:32
Сайт превосходный!!! Огромный респект автору! Очень помогает этот сайт в работе. спасибо БОЛЬШОЕ!!!!!.
27.12.2012 19:07:34
А как сделать, чтоб открывалась форма с несколькими параметрами на данного человека? Например, день рождения,адрес, телефон и т.д. Очень классный сайт!!!
20.01.2013 19:21:08
Это вам полноценную базу данных нужно. Копайте в сторону Access.:)
29.12.2012 17:25:32
Выпадающий список с добавлением новых элементов
А у меня что-то не получается, все вроде ввел как надо в всплывающем окне список есть но когда в нем пишешь новые данные то они не добавляются в основной список .
20.01.2013 19:19:44
Защита от макросов не включена, часом?
Вкладка Разработчик - Безопасность - Низкий уровень и переоткрыть Excel.
21.01.2013 12:32:25
Да все получилось, спасибо!!!
А подскажите еще пожалуйста,как вписать в "исходный текст не одну а несколько ячеек "$D$2" ; "$D$5"; и т. д.
22.01.2013 17:12:50
Да, хотелось бы узнать, как сделать такой список для нескольких ячеек сразу... Что нужно дописать или исправить в добавляемом макросе...
22.01.2013 23:40:26
Вместо 6 строки написать:
If Not Intersect(Target, Range("D2:D10")) Is Nothing Then
05.03.2013 14:45:27
Николай, добрый день!
Подскажите, как подправить макрос в следующем случае:
  • имеется таблица (порядка 600 строк) с несколькими столбцами;
  • к каждому столбцу привязаны выпадающие списки (именованные диаппазоны для списков на отдельном листе).
Задача: заменить ячейку D2 (из Вашего примера) на столбец "D:D" или Column(2). Хотел подсмотреть в макросе с выпадающим календарем по двойному клику, но Вы его удалили с нового сайта.
ЗЫ: в выпадающем списке видно 8 значений. можно ли увеличить данное число?

Заранее, спасибо!
08.03.2013 15:28:52
А почему бы аналогично не написать:
If Not Intersect(Target, Range("D2:D100000")) Is Nothing Then

Ответ на ваш второй вопрос - нет, больше 8 строк нельзя. Только, если использовать элементы управления или элемент ActiveX для создания вып.списка (почитайте про разные способы создания списков)
11.03.2013 14:05:34
Николай, Range("D2:D100000") не подходит. Указывая конкретные ячейки, мы ограничиваем диапазон срабатывания макроса. Поправил 6-ю строку на "If Target.Column = 4 Then" - работает :).
Но теперь не работает 8-я строка, т.к. список находится на другом листе (в 12 строке Вашего примера изменения внес).

PS: про элементы управления и ActiveX я в курсе, спасибо за ссылку.
23.01.2013 12:56:30
Николай подскажите,а как сделать так чтобы список да для нескольких ячеек работал,но с другого листа брал нужную информацию, у меня где то ошибка никак не соображу.:)
31.01.2013 11:07:51
В 12 строке макроса нужно дописать в начало ссылку на лист со списком, т.е.
Worksheets("Лист2").Range("People").Cells(Worksheets("Лист2").Range("People").Rows.Count + 1, 1) = Target
27.01.2017 14:11:30
Здравствуйте Николай!
Откуда можно скачать пример файла где сам список на одном листе, а ячейка для выбора из списка на другом листе?
20.05.2020 01:11:00
Пример файла 
Подскажите пожааста   что нужно изменить или  добавить в макросе, что бы  на одной странице   работало  две или  больше  ячейки  , и  добавляли новые данные  так же в  разные  "умные таблицы"   Напримере моего файла  Сотрудники  - это  одна я чейка , а клиенты  - другая.С одной ячейкой  разобрался , но вот две  не получается... :(
p.s. Я в программировании  полный нубас , в написании макросов  так же .Если  
будет возможность помочь ответом, то напишите  опираясь на мой файл плз.Спасибо!
24.01.2013 14:08:57
Добрый день, спасибо за интересный ЛИКБЕЗ, а как сделать, чтобы заполнять несколько разных списков из разных ячеек в одной таблице:  "счет №" в один список, а "наиминование" в другой. Спасибо.
26.01.2013 04:24:07
Отличный пример...то,что надо... Но задачу решаю следующую..В Вашем примере на первом лист одна таблица с ФИО и одна с выпдающими ячейками, а в моем случае.. 140 однотипичных страниц в одной книге. на каждой странице по 4 столбца с выпадающими списками... Сами списки хранятся на отдельном  листе  и у каждого диапазона соответственно свое название..Вопрос, как сделать, чтобы макрос обсчитывал все 140 листов и любые изменения в ячейках  соответственно заносил бы в соответствующих диапазонах, в которых хранятся списки (как я уже сказал на отдельном листе книги).. Вот несколько модифицированный пример этого макроса для одного листа и одного диапазона..И еще ячейки (4 на каждом листе в одном и том же месте, но не друг за другом) с выпадающим списком  у меня не друг за другом идут, т.е. их надо по отдельности прописывать в Range..Просто блоком не получится.., как в Вашем последнем примере..Range("Range("D2:D10";)Вот мой пример ...
 
Private Sub Worksheet_Change(ByVal Target As Range)
 
Dim lReply As Long
 
    If Target.Cells.Count > 1 Then Exit Sub
     If Not Intersect(Target, Range("AI8:AI27")) Is Nothing Then
      If IsEmpty(Target) Then Exit Sub
          If WorksheetFunction.CountIf(Sheets("PrintingOtherCosts").Range("sheet1"), Target) = 0 Then
           lReply = MsgBox("Äîáàâèòü ââåäåííîå èìÿ " & Target & " â âûïàäàþùèé ñïèñîê?", vbYesNo + vbQuestion)
            If lReply = vbYes Then
                Sheets("PrintingOtherCosts";).Range("sheet1").Cells(Sheets("PrintingOtherCosts").Range("sheet1").Rows.Count + 1, 1) = Target
            End If
          End If
     End If
End Sub
29.01.2013 01:08:53
Попробуйте использовать не событие Worksheet_Change, а Workbook_SheetChange - оно срабатывает при изменении любого листа книги. Тогда не надо будет руками вносить этот макрос в модуль каждого из 140 листов.

И проблема с несмежными диапазонам проверки решается легко - просто напишите несколько диапазонов через запятую внутри кавычек в операторе проверки:
If Not Intersect(Target, Range("AI8:AI27,C2:C45,B25") Is Nothing Then
19.02.2013 14:42:23
Здравствуйте! Отличная пошаговая инструкция. У меня то вопрос... В этом примере на листе одна таблица с ФИО и одна с выпадающими ячейками, у меня табличка с несколькими столбцами (одному я присвоила имя Form другому Manager) и таблица со столбцами Форма собственности и Первый руководитель. Осталось понять как сделать макрос, чтоб выпадающий список был в ячейках столбца Форма собственности из Form и в ячейках столбца Первый руководитель из Manager. Макрос из вашего примера сработал для Range Form в столбце Форма собственности, немного доработав его вот так:
Private Sub Worksheet_Change(ByVal Target As Range)

Dim lReply As Long

    If Target.Cells.Count > 1 Then Exit Sub
    If Not Intersect(Target, Range("C2:C485")) Is Nothing Then
     If IsEmpty(Target) Then Exit Sub
       If WorksheetFunction.CountIf(Range("Form"), Target) = 0 Then
          lReply = MsgBox("Добавить введенное имя " & _
                         Target & " в выпадающий список?", vbYesNo + vbQuestion)
          If lReply = vbYes Then
              Range("Form").Cells(Range("Form").Rows.Count + 1, 1) = Target
          End If
       End If
     End If
End Sub
Помогите пожалуйста из этого кода сделать так чтобы и с Range Manager была такая же песня... только вместо Range("C2:C485" было  Range("E2:E485"
Заранее благодарю!
20.02.2013 00:15:54
Да просто добавьте второй блок проверки и действий для вашего диапазона Manager. Вот так:
Private Sub Worksheet_Change(ByVal Target As Range)

Dim lReply As Long

    If Target.Cells.Count > 1 Then Exit Sub

    If Not Intersect(Target, Range("C2:C485")) Is Nothing Then
     If IsEmpty(Target) Then Exit Sub
       If WorksheetFunction.CountIf(Range("Form"), Target) = 0 Then
          lReply = MsgBox("Добавить введенное имя " & _
                         Target & " в выпадающий список?", vbYesNo + vbQuestion)
          If lReply = vbYes Then
              Range("Form").Cells(Range("Form").Rows.Count + 1, 1) = Target
          End If
       End If
     End If

   If Not Intersect(Target, Range("E2:E485")) Is Nothing Then
     If IsEmpty(Target) Then Exit Sub
       If WorksheetFunction.CountIf(Range("Manager"), Target) = 0 Then
          lReply = MsgBox("Добавить введенное имя " & _
                         Target & " в выпадающий список?", vbYesNo + vbQuestion)
          If lReply = vbYes Then
              Range("Manager").Cells(Range("Manager").Rows.Count + 1, 1) = Target
          End If
       End If
     End If


End Sub

21.02.2013 20:10:35
Сайт--песня. Но именно в данной теме, по крайней мере у меня, получился прокол.
Всё сделал, как описано (шаг 1-3). Но вставляется в последнюю строку диапазона. И только. И при этом затирает ранее введенное (на эту же последнюю строку) значение.  
21.02.2013 20:57:22
Антон, скачайте пример и посмотрите как оно работает. Предполагаю, что ошибка либо в именованном диапазоне People, либо в коде макроса.
27.02.2013 13:49:13
Добрый день. Подскажите пожалуйста как обозначить столбец "АА" либо "AB", проблема именно со столбцами у которых в название из двух букв, с одной буквой все отлично работает. Мой пример:
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Const a1 = "Добавить введенное имя ", a2 = " в выпадающий список?", a3 = "Gorod"
If Target.Cells.Count > 1 Then Exit Sub
a = Target.Address
If Left(a, 3) = "$AA$" And Val(Right(a, 2)) > 29 < 34 Then
    If IsEmpty(Target) Then Exit Sub
    If WorksheetFunction.CountIf(Range(a3), Target) = 0 Then
   If MsgBox(a1 & Target & a2, vbYesNo + vbQuestion) = vbYes Then _
      Range(a3).Cells(Range(a3).Rows.Count + 1, 1) = Target
    End If
End If
End Sub
28.02.2013 09:38:55
В пятой строке вашего макроса надо использовать свойства Column и Row, которые выдают номер столбца и строки для изменяемой ячейки Target:
If Target.Column=27 And Target.Column>29 and Target.Column<34 Then 
28.02.2013 12:37:33
Спасибо, Николай!!! Все работает.
If Target.Column = 27 And Target.Row > 29 And Target.Row < 34 Then
 
28.02.2013 21:52:10
Всем ЗДравствуйте! У меня возникла следующая  проблема. При вводе в поле ИСТОЧНИК = название именного диапазона (Например"месяц"), происходит повтор букв и формула естественно не работает. Т.е. выглядит это так: = мммееесссяяцц. Что это может быть?
03.03.2013 09:05:42
Глюк клавиатуры или руки дрожат? :)
04.03.2013 14:15:08
К сожалению, Николай, причина в чем-то другом. :D Клавиатура  не глючит, когда набираю текст на обычном листе, буквы повторяются именно при вводе в поле ИСТОЧНИК, и больше никогда (одно нажатие  - дает сразу две одинаковые буквы).  Проверила все галочки, сравнила с компом на работе. Всё везде одинаково, но на работе всё получается, а дома нет; точнее сказать получается и дома, просто вручную убираю лишние буквы. Возможно совпадение, возможно нет, но так стало, после того, как внезапно отключили в квартире электричество , потом естественно комп. перезагрузила, всё функционирует нормально, кроме ЭТОГО ммеессяяяцц! . Я  думала есть какая-то хитрая галочка, которую я не вижу, а она мне всё портит.Ну всё равно,;) спасибо за ответ, продолжу поиск загадочной "галочки".
08.03.2013 15:14:41
Тогда встречный вопрос - что у вас за версия Office? Лицензионная или пиратка? Обновлялись последний раз когда? Может дело в этом?
Я бы на вашем месте, как минимум, для начала попробовал переустановить Office.
30.10.2014 12:27:18
Войдите в надстройки Excel и отключите ненужные (подозрительные) надстройки.
Мне помогло. Были включены каки-то PDF расширения.
12.03.2013 15:53:48
Спасибо за Ваш ресурс, но у меня одна проблема - на что нужно заменить "Добавить введенное имя " и " в выпадающий список?" в англ. версии Excel 2007, чтобы макрос работал. А то у меня вместо русского текста показывает вопросительные знаки. Помогите пожалуйста!!! :)
14.03.2013 22:39:29
Сотрите вопросительные знаки и напишите этот текст еще раз по-русски - при копировании сбилась кодировка кириллицы, скорее всего.
15.03.2013 18:35:09
Случайно разобрался.) Работает с данными на другом листе. Может кому-нибудь нужно.
Private Sub Worksheet_Change(ByVal Target As Range)

Dim lReply As Long

    If Target.Cells.Count > 1 Then Exit Sub
        If Target.Address = "$D$2" Then
            If IsEmpty(Target) Then Exit Sub
                If WorksheetFunction.CountIf(Worksheets("Лист2").Range("People"), Target) = 0 Then
                    lReply = MsgBox("Добавить введенное имя " & Target & " в выпадающий список?", vbYesNo + vbQuestion)
                        If lReply = vbYes Then
                           Worksheets("Лист2").Range("People").Cells(Worksheets("Лист2").Range("People").Rows.Count + 1, 1) = Target
                        End If
                End If
        End If
End Sub

 
18.03.2013 12:02:34
Спасибо Виталий, но у меня выводит желтым следующую строку и  дальше не идет

If WorksheetFunction.CountIf(Worksheets("Sheet2").Range("PrNos"), Target) = 0 Then

Мой средний ум буксует, может кто путное что подскажет.
Спасибо!
18.03.2013 12:21:02
Интересно: включил пошаговое выполнение, редактор по очереди окрасил желтим все строки кода  и после этого работает без проблем -  новые данные в выподающий список вставляет.

Спасибо за сайт и за помощь ВСЕМ ЗНАТОКАМ и особенно АВТОРУ:D
18.03.2013 13:25:08
Еще возник вопрос у меня национальная клавиатура и настройли редактора я поменял. В окне кода сообщение отоброжаетса праильно а вот в таблице специфические буквы(ā,ī,š) ошибочно.

Что предпринять?
22.03.2013 13:33:48
Здравствуйте! Николай подскажите пожалуйста в чем ошибка (при попытке внести новое имя выскакивает макрос и выделяет цветом первую строку)? У меня офис 2010 и данные на одном листе, а таблица с ячейками куда вставлять данные на другом. И еще почему-то введя формулу =СМЕЩ(паспорта!$A$1;0;0;СЧЁТЗ(паспорта!$A$1:$A$100000);1) почему-то появляется список по порядку с другого запрашиваемого листа.



Private Sub Worksheet_Change(ByVal Target As Range)
Dim lReply As Long
    If Target.Cells.Count > 1 Then Exit Sub
    If Not Intersect(Target, Range("F2:F10") Is Nothing Then
     If IsEmpty(Target) Then Exit Sub
       If WorksheetFunction.CountIf(Range("клиентданные", Target) = 0 Then
          lReply = MsgBox("Добавить введенное имя " & _
                         Target & " в выпадающий список?", vbYesNo + vbQuestion)
          If lReply = vbYes Then
              Worksheets("паспорта".Range("клиентданные".Cells(Range("клиентданные".Rows.Count + 1, 1) = Target
          End If
       End If
     End If
End Sub


Заранее спасибо, ( на примере на одном листе пробовала все получалось правильно).
13.07.2013 17:45:46
Скачиваю пример, открываю, не работает – новое имя позволяет ввести, а в список не добавляет? В чем дело может быть?
24.09.2013 00:10:05
Private Sub Worksheet_Change(ByVal Target As Range)
Доброй ночи, такой вот макрос ошибку найти не могу


Dim lReply As Long

   If Target.Cells.Count > 1 Then Exit Sub
      If Not Intersect(Target, Range("f2:f100000")) Is Nothing Then
           If IsEmpty(Target) Then Exit Sub
              If WorksheetFunction.CountIf(Sheets("списки").Range("people"), Target) = 0 Then
                   lReply = MsgBox("Äîáàâèòü ââåäåííîå èìÿ " & Target & " â âûïàäàþùèé ñïèñîê?", vbYesNo + vbQuestion)
                       If lReply = vbYes Then
                          Sheets("списки").Range("people").Cells(Sheets("списки").Range("people").Rows.Count + 1, 1) = Target
               End If
       End If
   End If
End Sub
 
Не знаю что не так, новая запись в список не добавляется.Спасибо
25.11.2013 01:52:22
так как получилось у кого прикрутить к макросу упорядочить по алфавиту создаваемого диапазона
- чтобы в выпадающем списке всегда были строчи по порядку. Поделитесь примером пожалуйста
25.11.2013 16:40:34
На форуме спрашивали как сделать так, чтобы в список не только добавлялись новые значения, но и сортировались по алфавиту, у меня это получилось с помощью следующего кода:
Private Sub Worksheet_Change(ByVal Target As Range)

Dim lReply As Long

    If Target.Cells.Count > 1 Then Exit Sub
        If Not Intersect(Target, Range("D2:D10")) Is Nothing Then
            If IsEmpty(Target) Then Exit Sub
                If WorksheetFunction.CountIf(Sheets("Лист2").Range("people"), Target) = 0 Then
                    lReply = MsgBox("Добавить введенное имя " & Target & " в выпадающий список?", vbYesNo + vbQuestion)
                        If lReply = vbYes Then
                            Worksheets("Лист2").Range("People").Cells(Worksheets("Лист2").Range("People").Rows.Count + 1, 1) = Target
                        End If
                End If
        End If
    Sheets("Лист2").Range("A1:A1000").Sort Key1:=Sheets("Лист2").Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
    OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
    DataOption1:=xlSortNormal 'этот код и поможет отсортировать в алфавитном порядке
End Sub
 
надеюсь кому то поможет 8)
29.11.2013 10:18:53
Доброго времени суток! Сайт очень радует, и реально заражает Excel-ем)))
Стал активно юзать данный ресурс, и применять приемы в своей работе.
Относительно «Выпадающий список с добавлением новых элементов»:
-хотелось бы еще снабдить его очень полезным действием как интеллектуальное предложение данных из списка на вроде Т9 по первым набранным данным… Думаю выразился не очень но как то так))). Заранее СПС.;)
Страницы: 1  2  3  
Наверх