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

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

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

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

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

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

Шаг 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. Я в программировании  полный нубас , в написании макросов  так же .Если  
будет возможность помочь ответом, то напишите  опираясь на мой файл плз.Спасибо!
12.10.2020 09:10:40
Добрый день Николай, попробовал так как вы советуете:

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) то все работает.
12.10.2020 10:00:59
Геннадий, во-первых End Sub всегда должен быть в конце - это оператор завершения любого макроса.
Во-вторых, не видя вашего файла посоветовать что-то дельное - нереально.
Пришлите на почту или создайте тему на форуме - там еще быстрее помогут, скорее всего.
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

 
13.09.2020 19:25:50
не работае ваш макрос...
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), но видимо можно просто изменить как-то строку?
Влюбом случае спасибо!:)
Страницы: 1  2  3  
Наверх