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

Задача: сделать в ячейке D2 выпадающий список, чтобы пользователь мог выбирать имена из списка (столбец А). Если нужного имени нет в списке, то пользователь может ввести новое имя прямо в ячейку D2 - оно автоматически добавится к столбцу А и начнет отображаться в выпадающем списке в будущем. Вот так примерно:

add_to_dropdown1.gif

Шаг 1. Создаем именованный диапазон

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

  • в Excel 2007 и новее - жмем на вкладке Формулы (Formulas) кнопку Диспетчер имен (Name Manager) и затем Создать (New)
  • в Excel 2003 идем в меню Вставка - Имя - Присвоить (Insert - Name - Define)

Затем вводим имя диапазона (допустим People) и в строку Ссылка (Reference) вводим следующую формулу:

=СМЕЩ(Лист1!$A$1;0;0;СЧЁТЗ(Лист1!$A$1:$A$24);1)

в английской версии Excel это будет:

=OFFSET(Лист1!$A$1,0,0,COUNTA(Лист1!$A$1:$A$24),1)

Эта формула ссылается на все заполненные ячейки в столбце А, начиная с А1 и вниз до конца - до последнего имени.

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

Выделяем ячейку D2 и

  • в Excel 2007 и новее - жмем на вкладке Данные (Data) кнопку Проверка данных (Data Validation) 
  • в Excel 2003 и старше - выбираем в меню Данные - Проверка (Data - Validation).

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

add_to_dropdown2.gif

 

Чтобы Excel позволил нам в будущем ввести в список и новые имена, снимем галочки на вкладках Сообщение для ввода (Input Message) и Сообщение об ошибке (Error Alert) и нажмем ОК. Теперь у нас есть выпадающий список в ячейке D2. Причем, если, например, вручную дописать новое имя в столбце А, то оно автоматически появится в выпадающем списке в ячейке D2, поскольку имена берутся из динамического диапазона People, который автоматически отслеживает изменения в столбце А.

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

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

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(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
End Sub

Если Ваш выпадающий список находится не в ячейке D2 или Вы назвали диапазон с именами не People, а как-то еще, то подправьте эти параметры в макросе на свои.

Всё! Теперь при попытке ввести новое имя в ячейку D2 Excel будет спрашивать

add_to_dropdown3.gif

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

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


Страницы: 1  2  
Александр
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)
29.11.2013 10:18:53
Доброго времени суток! Сайт очень радует, и реально заражает Excel-ем)))
Стал активно юзать данный ресурс, и применять приемы в своей работе.
Относительно «Выпадающий список с добавлением новых элементов»:
-хотелось бы еще снабдить его очень полезным действием как интеллектуальное предложение данных из списка на вроде Т9 по первым набранным данным… Думаю выразился не очень но как то так))). Заранее СПС.;)
18.12.2013 16:40:25
в формуле есть СЧЕТ3.
=СМЕЩ(Лист1!$A$1;0;0;СЧЁТЗ(Лист1!$A$1:$A$24);1)
что это?
05.01.2014 09:46:43
Добрый день!
Хочу поблагодарить за этот замечательный ресурс! Подобных в интернете еще не встречала. Очень помогает!
Николай, у меня вопрос. Модифицировала данный макрос для работы с повторяющимся выпадающим списком в нужном мне столбце. Данные при этом находятся на другом листе. Также добавила сортировку по алфавиту (спасибо другим участникам форума за советы). Получился следующий макрос:

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. некоторые пользователи нажимают отмену, и вроде информация в таблице есть, а в списке нет).

Спасибо!
05.01.2014 15:25:36
Анна,
код надо вставлять уже не в модуль листа, а в модуль книг, т.к. он 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
13.01.2014 14:46:21
Николай, спасибо за полезный сайт. Создал выпадающий список по инструкции, но при его открытии, курсор списка находится ниже записей, т.е. приходится вручную подвигать курсор вверх списка, чтобы выбрать один из вариантов. В чем может быть дело ?  Что сделать, чтобы список открывался с самого верха ? Спасибо.
21.01.2014 18:21:02
Здравствуйте!
Огромное спасибо, за столько много советов. У меня возникла проблема, если можно так сказать. У меня в фаиле связаные выпадаюсчие списки, которые сделаны по вашему методу с помощью формулы INDIRECT.  Но вот когда я добавляю новое наименование, добавляется целая строка, а не ячейка в нужном столбце. Скажите, пожалуйста, как ето обоити?
P.S. Извините за русский, я из Риги. :)
30.01.2014 11:29:00
Николай, добрый день, спасибо вам огромное за великолепный сайт и доброе отношение ко всем его посетителям независимо от их опыта и навыков.  С вами постигаю VBA.
А вы можете показать на вашем коде как реализовать добавление новых элементов в форме. Т.е. есть форма, в ней ComboBox со своим RowSource. Как добавить новый элемент в этом случае? Т.е. чтобы набрать его в поле ComboBox, а он бы добавился и в RowSource потом без создания/октрытия дополнительных форм.
03.02.2014 18:12:30
Добрый вечер!  Помогите пожалуйста решить задачу))  как быть, если есть 5 книг (идентичных) с выпадающими списками с возможностью добавления новых элементов, и надо, чтобы добавленный элемент в книге 1 появлялся и в списках остальных книг?

Заранее спасибо!
05.03.2014 15:10:02
Добрый день. Сайт действительно полезный. Сделал все как в примерах - работает! С добавлением проблем нет. Подскажите пожалуйста, какой код надо добавить чтоб еще и удалив из выпадающего списка удалялось из таблицы
01.04.2014 14:32:53
Здравствуйте Николай.
Огромное СПАСИБО за ВАШ сайт - очень много полезного!

С первого раза разобрался с данным примером... Сделал выпадающий список + добавление новых элементов+сортировка БАЗЫ элементов.

У меня получлся такой макрос:

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) - Мои познания или руки оказались кривыми!
01.04.2014 20:13:53
Удалось прикрутить:D
16.04.2014 09:53:14
Сергей, можете поделиться своим счастьем?
Сейчас, как раз пытаюсь решить подобную задачу...
16.04.2014 11:00:52
стучи на скайп: drinkerdp
30.10.2014 17:32:21
Поделитесь радостью? ))
16.04.2014 10:33:55
жаль, что на Android этот макрос не отрабатывает :(
Выпадающий список только...
16.04.2014 11:03:55
на Android у тебя стоит тоже Excel??
16.04.2014 11:18:27
KingSoft Office стоит, многие стандартные фишки Excell тянет без проблем :)
Но при вводе новых данных, то есть когда отрабатывает макрос, вываливает ошибку

The value is not valid! 
The cell can only accept list format within effective range! 
А работать с таблицей приходится в 95% случаев на телефоне
08.05.2014 10:17:12
Вот тут я не помощник - андроидов у меня ни одного в жизни еще не было, как-то не сложилось у меня с ними :)
Может кто из коллег поможет - попробуйте на форуме тему озвучить.

Вообще говоря, не видел ни одного ни телефона, ни планшета, ни программы, где работали бы макросы. Только Surface и полноценный Office, но это уже полноценный компьютер, фактически.
24.04.2014 11:10:04
А почему никто не пользуется "умными таблицами"? По мне, так очень удобно. Вместо ограничения диапазона в макросе, либо назначение определенному диапазону, сделав свою таблицу "умной", использовать в качестве нужного диапазона, готовое имя столбца - вместо ... Range("People")... использовать ... Range("Таблица1[Столбец1]")... При этом, диапазон будет расширяться динамически, в зависимости от необходимого размера)
08.05.2014 10:12:19
Пользуемся, еще как пользуемся. У них, правда, свои ограничения (совместимость со старыми версиями и т.д.)
24.06.2014 10:57:30
Просто отличная штука! Спасибо за сайт!
В макросах не разбираюсь, просто на примерах и ваших подсказках пытаюсь подкрутить под себя. Есть вопрос - как сделать чтобы выпадало не полностью по столбцу D2: D20, а D2... D4... D6 и так далее... конечно можно копировать блок и полставлять так для каждой ячейки(D2... D4... D6), но видимо можно просто изменить как-то строку?
Влюбом случае спасибо!:)
30.07.2014 09:55:45
Спасибо автору сайта и всем советчикам! Все получилось и так как нужно!
26.08.2014 05:06:55
Доброго времени. Очень понравились толковые разъяснения, помогли во многом.
Николай, возможно, Вы сможете и мне помочь: есть файл, в котором
таблица находится на одном листе, а ввожу в нее данные с другого листа (этой же книги). Excel 2003

Нужно, чтобы добавлялись несколько разных значений ФИО, возраст и т.п.
По Вашему примеру Все работает, но только если таких данных еще нет. Есть ли возможность чтобы в таблицу вносились и дублируемые данные, которые уже есть в таком столбце, т.е. ниже имеющихся сведений добавлялась следующая запись.  Например возраст может быть у разных людей одинаковым, как и некоторые другие данные, или если человек обратился несколько раз - информация о нем должна быть внесена.

Но, возможно, Вы сможете посоветовать более простой способ ввода информации в таблицу, из ячеек которые находятся на другом листе?
Страницы: 1  2