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

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

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

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

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

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

Шаг 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
Здравствуйте Николай!
Откуда можно скачать пример файла где сам список на одном листе, а ячейка для выбора из списка на другом листе?
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)
Страницы: 1  2  3  
Наверх