Добрый день! Помогите, пож, решить проблему - на одном листе в таблице есть 3 выпадающих списка с разными диапазонами данных - как сделать автоматическое пополнение диапазона (если данных нет, а значение вводится в ячейке списка) по каждому списку. нашёл один макрос - он работает, но только по одному списку - как его "размножить" на все три? Пример макроса:
[vba]
Код
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("перевозчик1")) 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
[/vba]
заранее благодарю!
Добрый день! Помогите, пож, решить проблему - на одном листе в таблице есть 3 выпадающих списка с разными диапазонами данных - как сделать автоматическое пополнение диапазона (если данных нет, а значение вводится в ячейке списка) по каждому списку. нашёл один макрос - он работает, но только по одному списку - как его "размножить" на все три? Пример макроса:
[vba]
Код
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("перевозчик1")) 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
Здравствуйте. Файла нет, проверить не на чем, принцип такой [vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range) Set p = Range("перевозчик") Set p1 = Range("перевозчик1") Set p2 = Range("перевозчик2") If Target.Cells.Count > 1 Then Exit Sub If IsEmpty(Target) Then Exit Sub If Not Intersect(Target, Range("список")) 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 ElseIf Not Intersect(Target, Range("список1")) Is Nothing Then If WorksheetFunction.CountIf(p1, Target) = 0 Then r = MsgBox("Добавить новое имя в справочник?", vbYesNo) If r = vbYes Then p1.Cells(p1.Rows.Count + 1) = Target End If ElseIf Not Intersect(Target, Range("список2")) Is Nothing Then If WorksheetFunction.CountIf(p2, Target) = 0 Then r = MsgBox("Добавить новое имя в справочник?", vbYesNo) If r = vbYes Then p2.Cells(p2.Rows.Count + 1) = Target End If End If End Sub
[/vba]
Здравствуйте. Файла нет, проверить не на чем, принцип такой [vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range) Set p = Range("перевозчик") Set p1 = Range("перевозчик1") Set p2 = Range("перевозчик2") If Target.Cells.Count > 1 Then Exit Sub If IsEmpty(Target) Then Exit Sub If Not Intersect(Target, Range("список")) 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 ElseIf Not Intersect(Target, Range("список1")) Is Nothing Then If WorksheetFunction.CountIf(p1, Target) = 0 Then r = MsgBox("Добавить новое имя в справочник?", vbYesNo) If r = vbYes Then p1.Cells(p1.Rows.Count + 1) = Target End If ElseIf Not Intersect(Target, Range("список2")) Is Nothing Then If WorksheetFunction.CountIf(p2, Target) = 0 Then r = MsgBox("Добавить новое имя в справочник?", vbYesNo) If r = vbYes Then p2.Cells(p2.Rows.Count + 1) = Target End If End If End Sub
Pelena, Вы почему то не обратили внимание, что макрос ТС одноразовый и просто его размножили, при первом добавлении нового значения в "список" оно добавится в строку ниже диапазона "перевозчик", а вот при следующем добавлении будет перезаписано предыдущее значение на новое. Целевой диапазон то не изменился. Конечно можно из целевых диапазонов сделать умные таблицы и изменить способ адресации, работать будет. Но для реальной работы это называется "через ж...", обычный пользователь не должен лезть в источники данных для списков. Если нужно добавить новые данные в списки, то это нужно делать в самой рабочей таблице. А вот тут и должен сработать макрос и спросить у пользователя -добавлять или нет это в справочник.
Pelena, Вы почему то не обратили внимание, что макрос ТС одноразовый и просто его размножили, при первом добавлении нового значения в "список" оно добавится в строку ниже диапазона "перевозчик", а вот при следующем добавлении будет перезаписано предыдущее значение на новое. Целевой диапазон то не изменился. Конечно можно из целевых диапазонов сделать умные таблицы и изменить способ адресации, работать будет. Но для реальной работы это называется "через ж...", обычный пользователь не должен лезть в источники данных для списков. Если нужно добавить новые данные в списки, то это нужно делать в самой рабочей таблице. А вот тут и должен сработать макрос и спросить у пользователя -добавлять или нет это в справочник.i691198
Спасибо большое за отзывчивость - исправляюсь - прикладываю часть таблицы для которой и необходим данный макрос. (три нужных выпадающих списка выделил красным) Спасибо за помощь!
Спасибо большое за отзывчивость - исправляюсь - прикладываю часть таблицы для которой и необходим данный макрос. (три нужных выпадающих списка выделил красным) Спасибо за помощь!vitalik8307
В моём макросе просто надо имена заменить на актуальные [vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range) Set p = Range("перевозчик") Set p1 = Range("тягач") Set p2 = Range("прицеп") If Target.Cells.Count > 1 Then Exit Sub If IsEmpty(Target) Then Exit Sub If Not Intersect(Target, Range("перевозчик1")) 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 ElseIf Not Intersect(Target, Range("тягач1")) Is Nothing Then If WorksheetFunction.CountIf(p1, Target) = 0 Then r = MsgBox("Добавить новое имя в справочник?", vbYesNo) If r = vbYes Then p1.Cells(p1.Rows.Count + 1) = Target End If ElseIf Not Intersect(Target, Range("прицеп1")) Is Nothing Then If WorksheetFunction.CountIf(p2, Target) = 0 Then r = MsgBox("Добавить новое имя в справочник?", vbYesNo) If r = vbYes Then p2.Cells(p2.Rows.Count + 1) = Target End If End If End Sub
[/vba]
В моём макросе просто надо имена заменить на актуальные [vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range) Set p = Range("перевозчик") Set p1 = Range("тягач") Set p2 = Range("прицеп") If Target.Cells.Count > 1 Then Exit Sub If IsEmpty(Target) Then Exit Sub If Not Intersect(Target, Range("перевозчик1")) 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 ElseIf Not Intersect(Target, Range("тягач1")) Is Nothing Then If WorksheetFunction.CountIf(p1, Target) = 0 Then r = MsgBox("Добавить новое имя в справочник?", vbYesNo) If r = vbYes Then p1.Cells(p1.Rows.Count + 1) = Target End If ElseIf Not Intersect(Target, Range("прицеп1")) Is Nothing Then If WorksheetFunction.CountIf(p2, Target) = 0 Then r = MsgBox("Добавить новое имя в справочник?", vbYesNo) If r = vbYes Then p2.Cells(p2.Rows.Count + 1) = Target End If End If End Sub
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
