Выпадающий список с добавлением новых элементов
Предположим, что у нас есть справочник с именами сотрудников и таблица, куда этих сотрудников нужно вносить:
Задача состоит из двух частей:
- Сделать выпадающий список, причем так, чтобы при дописывании новых людей к справочнику - они автоматически появлялись и в выпадающем списке.
- Реализовать возможность добавления новых людей в список и с другой стороны - при вводе нового имени в любую из жёлтых ячеек оно должно автоматически добавляться к справочнику (и в выпадающий список в будущем, само-собой).
Такая вот двухсторонняя связь справочника и выпадающего списка.
Шаг 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
- Связанные выпадающие списки (от того, что выбрано в первом - зависит содержимое второго)
- Выпадающий список для выбора изображений (фотографий товаров, сотрудников и т.д.)
Помогите, пожалуйста, объединить два макроса в один
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
И
Private Sub Worksheet_Change(ByVal Target As Range)
For Each cell In Target '
If Not Intersect(cell, Range("A3:A100" Is Nothing Then '
With cell.Offset(0, 1) '
Application.Calculation = xlManual
.Value = Now
Application.Calculation = xlAutomatic
End With
End If
Next cell
For Each cell In Target '
If Not Intersect(cell, Range("F3:F100" Is Nothing And cell Like "Устранено*" Then '
With cell.Offset(0, 1) '
Application.Calculation = xlManual
.Value = Now
Application.Calculation = xlAutomatic
End With
End If
Next cell
End Sub
Option Explicit Option Compare Text Dim bu As Boolean Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.CountLarge > 1 Then Exit Sub If Target.Row = 1 Then Me.TextBox1.Visible = False: Me.ListBox1.Visible = False: Exit Sub If Target.Column = 3 Then ' номер столбца, в который вносим значения bu = True With Me.TextBox1 .Top = Target.Top: .Text = Target.Value: .Activate End With With Me.ListBox1 .Top = Target.Top + 5 If (.Top + .Height + ActiveWindow.PointsToScreenPixelsY(0) * Application.InchesToPoints(1) * 15 / 1440) > _ (ActiveWindow.Application.Height + ActiveWindow.Application.Top) Then _ .Top = .Top - .Height + Target.Height '* ActiveWindow.Zoom / 100 .Clear End With bu = False Me.TextBox1.Visible = True: Me.ListBox1.Visible = True Else Me.TextBox1.Visible = False: Me.ListBox1.Visible = False End If End Sub Private Sub TextBox1_Change() If Len(TextBox1.Text) = 0 Or bu Then Exit Sub 'при отсутствии символов для поиска - выход Dim x, i As Long, txt As String, lt As Long, s As String txt = TextBox1.Text: lt = Len(TextBox1.Text) 'Где ищем значения x = Sheets("номенклатура";).Columns(1).SpecialCells(2).Offset(1).Value ' For i = 1 To UBound(x, 1) ' поиск по первым буквам 'If txt = Mid(x(i, 1), 1, lt) Then s = s & x(i, 1) & "~" For i = 1 To UBound(x, 1) 'поиск по любому вхождению If InStr(x(i, 1), txt) Then s = s & "~" & x(i, 1) Next i ListBox1.List = Split(s, "~";) End Sub Private Sub TextBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) If KeyCode = 13 Or KeyCode = 9 Then With Me.TextBox1 ActiveCell.Value = .Value .Visible = False: ListBox1.Visible = False End With ActiveCell(2, 1).Select End If End Sub Private Sub ListBox1_Click() If ListBox1.ListIndex = -1 Then Exit Sub Application.EnableEvents = False bu = True With Me.ListBox1 ActiveCell.Value = .Value Me.TextBox1.Text = .Value Me.TextBox1.Visible = False: .Visible = False End With Application.EnableEvents = True bu = False End Sub Private Sub Worksheet_Change(ByVal Target As Range) Dim lReply As Long If Target.Column = 2 Then Exit Sub If Not Intersect(Target, Range("C2:C100000";)) Is Nothing Then If IsEmpty(Target) Then Exit Sub If WorksheetFunction.CountIf(Sheets("номенклатура";).Columns(1), Target) = 0 Then lReply = MsgBox("Добавить введенное имя " & Target & " в выпадающий список", vbYesNo + vbQuestion) If lReply = vbYes Then Worksheets("номенклатура";).Range("номенклатура";).Cells(Worksheets("номенклатура";).Range("номенклатура";).Rows.Count + 1, 1) = Target End If End If End If Sheets("номенклатура";).Range("номенклатура";).Sort Key1:=Sheets("номенклатура";).Range("A1";), Order1:=xlAscending, Header:=xlGuess, _ OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _ DataOption1:=xlSortNormal 'этот код и поможет отсортировать в алфавитном порядке' End SubПомогите написать правильно в макрос формулу ВПР это для того, чтобы при выборе в выпадающем списке "формула" происходило вычисление по заданной формуле.
У меня все таблицы с данными:
- Искомое значение в ВПР находиться на том же листе что и ячейка с выпадающим списком F2, то есть "Заявка" столбец "Серийный номер компонента" в нем первое значение "E2"
- Таблица находиться на другом листе "ActiveComponentDetails" диапазон A:BA
- Номер столбца на том же листе - 37
В данном виде выделяет данную строчку желтым.
Спасибо большое.
Private Sub Worksheet_Change(ByVal Target As Range)
If Target <> [F2] Then Exit Sub
If Target.Value = "формула" Then Target.Formula = "=ЕСЛИОШИБКА(ВПР([@[Серийный номер компонента]];ActiveComponentDetails!A:BA;37;0);"""
End Sub
можно ли сделать на одном листе несколько раскрывающихся списков и под каждый из списков будет свой справочник на том же листе?
что надо в макросе менять (кроме ссылок на диапазоны)?
Мне данная кодировка не помогает. Что там нужно менять? Поможете?
И меня это интересует.
Private Sub Workbook_SheetChange(ByVal Target As Range)
Set p = Range("Источник2")
If Target.Cells.Count > 1 Then Exit Sub
If IsEmpty(Target) Then Exit Sub
If Not Intersect(Target, Range ("c2:c1000,d2:d1000") Is Nothing Then
If WorksheetFunction.CountIf(p, Target) = 0 Then
r = MsgBox("Taze sozi gosjakmy?", vbYesNo)
If r = vbYes Then p.Cells(p.Rows.Count + 1) = Target
End If
End If
End Sub
В моем файле на листе 1 Справочник-Именованный список "Сырье_и_Материалы". На листе 2 калькуляция с добавлением элементов из выпадающего списка, таких листов будет множество. Макрос не срабатывает, ошибка Run time error "1004". Подсвечивает ошибку Set p = Range("Сырье_и_Материалы"). Думаю, что нужно указывать листы, но не знаю, как...помогите, пожалуйста
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("A2:A100")) 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-2019 (при вводе нового имени в ячейке с выпад списком, оно не появляется в справочнике). Никаких ошибок не выдает. Во вкладке безопасности запретов нет. Это проблема в версии?
Set p = Worksheets("Лист1").Range("Люди")
If Target.Cells.Count > 1 Then Exit Sub
If IsEmpty(Target) Then Exit Sub
If Not Intersect(Target, Worksheets("Лист2").Range("C5")) 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