Выпадающий список с добавлением новых элементов
Предположим, что у нас есть справочник с именами сотрудников и таблица, куда этих сотрудников нужно вносить:
Задача состоит из двух частей:
- Сделать выпадающий список, причем так, чтобы при дописывании новых людей к справочнику - они автоматически появлялись и в выпадающем списке.
- Реализовать возможность добавления новых людей в список и с другой стороны - при вводе нового имени в любую из жёлтых ячеек оно должно автоматически добавляться к справочнику (и в выпадающий список в будущем, само-собой).
Такая вот двухсторонняя связь справочника и выпадающего списка.
Шаг 1. Создаем умную таблицу
Сначала превратим справочник в "умную" таблицу, чтобы воспользоваться одним из главных её преимуществ - динамической автоподстройкой размеров при добавлении новых данных.
Для этого выделим весь справочник (ячейки A1:A7) и нажмём сочетание клавиш Ctrl+T или выберем Главная - Форматировать как таблицу (Home - Format as Table). В следующем окне можно смело жать ОК:
Шаг 2. Создаем динамический именованный диапазон
Теперь создадим именованный диапазон, указывающий на заполненные именами ячейки в нашем справочнике. Для этого выделим в справочнике уже только имена без шапки (ячейки A2:A7) и в левой части строки формул (там будет имя таблицы) введём имя для нашего диапазона (например Люди):
После ввода имени обязательно нужно нажать на клавишу Enter - слово Люди исчезнет из этого поля, но диапазон будет создан.
Хитрость тут в том, что поскольку мы выделяли столбец уже в "умной" таблице, то и именованный диапазон у нас получился завязанным на колонку [Справочник], а не на конкретные выделенные ячейки. Убедиться в этом можно, если выбрать на вкладке Формулы команду Диспетчер имен (Formulas - Name Manager) и посмотреть куда ссылается имя Люди:
Шаг 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 будет спрашивать:
... и при утвердительном ответе пользователя автоматически добавлять новое имя к справочнику и в выпадающий список в дальнейшем.
Ссылки по теме
- 4 способа создать выпадающий список в ячейке листа
- Как создать список из которого будут автоматически удаляться использованные элементы
- Автоматическое создание списка при помощи надстройки PLEX
- Связанные выпадающие списки (от того, что выбрано в первом - зависит содержимое второго)
- Выпадающий список для выбора изображений (фотографий товаров, сотрудников и т.д.)
Ну вот и у меня возник вопрос, причем достаточно срочный, спасайте: в данном примере (описаном выше) в качестве ячейки для выбора/ввода нового значения - указана одна ячейка. Как сделать так, чтобы при вводе данных в диапазон, к примеру, D2:D10, в любую из этих ячеек, происходила проверка и добавление в список. Прописать в стоорке If Target.Adress= и так далее 10 раз, можно через or, но мне нужен диапазон в 4000 строк
Пробовала вводить диапазон ячеек, сохраняю изменения, но при вводе информации в ячейку, Эксель не предлагает добавить ее в список.
Изменение параметра Target.Cells.Count тоже ни к чему не приводит.
У кого-нибудь есть идеи?
В этом примере небольшая ошибка, в английской версии формулы стоят запятые, а нужны точки с запятой. Иначе эксель ругается:).
А у меня что-то не получается, все вроде ввел как надо в всплывающем окне список есть но когда в нем пишешь новые данные то они не добавляются в основной список .
Вкладка Разработчик - Безопасность - Низкий уровень и переоткрыть Excel.
А подскажите еще пожалуйста,как вписать в "исходный текст не одну а несколько ячеек "$D$2" ; "$D$5"; и т. д.
If Not Intersect(Target, Range("D2:D10")) Is Nothing ThenПодскажите, как подправить макрос в следующем случае:
- имеется таблица (порядка 600 строк) с несколькими столбцами;
- к каждому столбцу привязаны выпадающие списки (именованные диаппазоны для списков на отдельном листе).
Задача: заменить ячейку D2 (из Вашего примера) на столбец "D:D" или Column(2). Хотел подсмотреть в макросе с выпадающим календарем по двойному клику, но Вы его удалили с нового сайта.ЗЫ: в выпадающем списке видно 8 значений. можно ли увеличить данное число?
Заранее, спасибо!
If Not Intersect(Target, Range("D2:D100000")) Is Nothing ThenОтвет на ваш второй вопрос - нет, больше 8 строк нельзя. Только, если использовать элементы управления или элемент ActiveX для создания вып.списка ()
Но теперь не работает 8-я строка, т.к. список находится на другом листе (в 12 строке Вашего примера изменения внес).
PS: про элементы управления и ActiveX я в курсе, спасибо за ссылку.
Worksheets("Лист2").Range("People").Cells(Worksheets("Лист2").Range("People").Rows.Count + 1, 1) = TargetОткуда можно скачать пример файла где сам список на одном листе, а ячейка для выбора из списка на другом листе?
p.s. Я в программировании полный нубас , в написании макросов так же .Если
будет возможность помочь ответом, то напишите опираясь на мой файл плз.Спасибо!
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("H12:H100") 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
Worksheets("Лист1").Range("ГДО").Cells(Worksheets("Лист1")Range("ГДО").Rows.Count + 1, 1) = Target
Список с данными на "Лист1", а выпадающий список на "Лист2". Но выдает ошибку: "Compile error: Only comments may appear after End Sub, End function, оr End Property."
Если и выпадающий список и список с данными на одном листе(Лист2) то все работает.
Во-вторых, не видя вашего файла посоветовать что-то дельное - нереально.
Пришлите на почту или создайте тему на форуме - там еще быстрее помогут, скорее всего.
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И проблема с несмежными диапазонам проверки решается легко - просто напишите несколько диапазонов через запятую внутри кавычек в операторе проверки:
If Not Intersect(Target, Range("AI8:AI27,C2:C45,B25") Is Nothing Then
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Заранее благодарю!
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Всё сделал, как описано (шаг 1-3). Но вставляется в последнюю строку диапазона. И только. И при этом затирает ранее введенное (на эту же последнюю строку) значение.
Я бы на вашем месте, как минимум, для начала попробовал переустановить Office.
Мне помогло. Были включены каки-то PDF расширения.
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 SubIf WorksheetFunction.CountIf(Worksheets("Sheet2").Range("PrNos"), Target) = 0 Then
Мой средний ум буксует, может кто путное что подскажет.
Спасибо!
Спасибо за сайт и за помощь ВСЕМ ЗНАТОКАМ и особенно АВТОРУ
Что предпринять?
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Заранее спасибо, ( на примере на одном листе пробовала все получалось правильно).
Доброй ночи, такой вот макрос ошибку найти не могу
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
Не знаю что не так, новая запись в список не добавляется.Спасибо
- чтобы в выпадающем списке всегда были строчи по порядку. Поделитесь примером пожалуйста
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Стал активно юзать данный ресурс, и применять приемы в своей работе.
Относительно «Выпадающий список с добавлением новых элементов»:
-хотелось бы еще снабдить его очень полезным действием как интеллектуальное предложение данных из списка на вроде Т9 по первым набранным данным… Думаю выразился не очень но как то так))). Заранее СПС.
=СМЕЩ(Лист1!$A$1;0;0;СЧЁТЗ(Лист1!$A$1:$A$24);1)
что это?
Хочу поблагодарить за этот замечательный ресурс! Подобных в интернете еще не встречала. Очень помогает!
Николай, у меня вопрос. Модифицировала данный макрос для работы с повторяющимся выпадающим списком в нужном мне столбце. Данные при этом находятся на другом листе. Также добавила сортировку по алфавиту (спасибо другим участникам форума за советы). Получился следующий макрос:
Private Sub Workbook_SheetChange(ByVal Target As Range)
Dim lReply As Long
If Target.Cells.Count > 1 Then Exit Sub
If Not Intersect(Target, Range("H6:H30")) Is Nothing Then
If IsEmpty(Target) Then Exit Sub
If WorksheetFunction.CountIf(Worksheets("hidden2").Range("stores"), Target) = 0 Then
lReply = MsgBox("Would you like to add new store " & Target & " to your database?", vbYesNo + vbQuestion)
If lReply = vbYes Then
Worksheets("hidden2").Range("stores").Cells(Worksheets("hidden2").Range("stores").Rows.Count + 1, 1) = Target
End If
End If
End If
Sheets("hidden2").Range("C1:C1000").Sort Key1:=Sheets("hidden2").Range("C1"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal 'this cod will help to range your stores
End Sub
Вопрос в следующем:
У меня в книге 12 листов с повторяющимися данными и, соответственно, одинаковым выпадающим списком. Попробовала применить выше описанную замену события Worksheet_Change на Workbook_SheetChange. Не работает. Что я делаю не так? Также можно ли в макросе просто прописать названия страниц или он будет работать для всей книги в целом (у меня есть лист итогов, где мне данный макрос на тех же самых ячейках не нужен совсем)?
И еще один вопрос. В данном макросе если вводишь новое название в ячейку и нажимаешь потом не на подтверждение, а на команду отмены, введенное слово в ячейке все равно остается (в список, естественно, не добавляется). Можно ли прописать какую-то команду, чтобы в случае нажатия отмены введенное слово удалялось автоматически и ячейка оставалась пустой? (p.s. некоторые пользователи нажимают отмену, и вроде информация в таблице есть, а в списке нет).
Спасибо!
код надо вставлять уже не в модуль листа, а в модуль книг, т.к. он SheetChange - это уже событие книги, а не отдельного листа. Для этого нажмите Alt+F11 и в левом верхнем углу найдите и откройте двойным щелчком модуль ЭтаКнига (ThisWorkbook).
Туда нужно вставить вот такой подкорректированный код макроса:
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range) Dim lReply As Long If Target.Cells.Count > 1 Then Exit Sub 'если выделено больше одной ячейки - выходим If Sh.Name = "Итог" Then Exit Sub 'если это лист Итог - выходим If IsEmpty(Target) Then Exit Sub 'если ячейку очистили - выходим If Not Intersect(Target, Range("H6:H30")) Is Nothing Then Application.EnableEvents = False If WorksheetFunction.CountIf(Worksheets("hidden2").Range("stores"), Target) = 0 Then lReply = MsgBox("Would you like to add new store " & Target & " to your database?", vbYesNo + vbQuestion) If lReply = vbYes Then 'если нажали ДА - добавляем новый элемент к списку Worksheets("hidden2").Range("stores").Cells(Worksheets("hidden2").Range("stores").Rows.Count + 1, 1) = Target Else 'если нажали НЕТ - очищаем ячейку Target.ClearContents End If End If End If 'сортируем список Sheets("hidden2").Range("C1:C1000").Sort Key1:=Sheets("hidden2").Range("C1"), Order1:=xlAscending, Header:=xlGuess, _ OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal Application.EnableEvents = True End SubОгромное спасибо, за столько много советов. У меня возникла проблема, если можно так сказать. У меня в фаиле связаные выпадаюсчие списки, которые сделаны по вашему методу с помощью формулы INDIRECT. Но вот когда я добавляю новое наименование, добавляется целая строка, а не ячейка в нужном столбце. Скажите, пожалуйста, как ето обоити?
P.S. Извините за русский, я из Риги.
А вы можете показать на вашем коде как реализовать добавление новых элементов в форме. Т.е. есть форма, в ней ComboBox со своим RowSource. Как добавить новый элемент в этом случае? Т.е. чтобы набрать его в поле ComboBox, а он бы добавился и в RowSource потом без создания/октрытия дополнительных форм.
Заранее спасибо!
Огромное СПАСИБО за ВАШ сайт - очень много полезного!
С первого раза разобрался с данным примером... Сделал выпадающий список + добавление новых элементов+сортировка БАЗЫ элементов.
У меня получлся такой макрос:
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:D100000")) Is Nothing Then If IsEmpty(Target) Then Exit Sub If WorksheetFunction.CountIf(Range("People"), Target) = 0 Then lReply = MsgBox("Добавить введенное имя " & _ Target & " в выпадающий список?", vbYesNo + vbQuestion) If lReply = vbYes Then Range("People").Cells(Range("People").Rows.Count + 1, 1) = Target End If End If End If Range("People").Sort Key1:=Range("People"), Order1:=xlAscending, Header:=xlGuess, _ OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _ DataOption1:=xlSortNormal 'this cod will help to range your stores End SubОстался единственный вопрос.
Можно ли прикрутить к данному макросу еще и автоподстановку (автоподбор) значений по первым вводимым символам?
Так как имеется перечень з/частей (более 100) и отбор осуществляется по значению кода з/ч (ПРИМЕР: 200.235.145.010).
Нашел в сети Надстройку, но .... к ней не прикручивается выше приведенный макрос!
Заранее спасибо!
С уважением,
Сергей.
Пы.Сы. Пытался прикрутить к вышеуказанному макросу НАДСТРОЙКУ (DropDownList) - Мои познания или руки оказались кривыми!
Сейчас, как раз пытаюсь решить подобную задачу...
Выпадающий список только...
Но при вводе новых данных, то есть когда отрабатывает макрос, вываливает ошибку
Может кто из коллег поможет - попробуйте на форуме тему озвучить.
Вообще говоря, не видел ни одного ни телефона, ни планшета, ни программы, где работали бы макросы. Только Surface и полноценный Office, но это уже полноценный компьютер, фактически.
В макросах не разбираюсь, просто на примерах и ваших подсказках пытаюсь подкрутить под себя. Есть вопрос - как сделать чтобы выпадало не полностью по столбцу D2: D20, а D2... D4... D6 и так далее... конечно можно копировать блок и полставлять так для каждой ячейки(D2... D4... D6), но видимо можно просто изменить как-то строку?
Влюбом случае спасибо!