Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/выпадающий список с автомат. пополнением диапазона данных - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_  
выпадающий список с автомат. пополнением диапазона данных
vitalik8307 Дата: Суббота, 29.04.2023, 11:34 | Сообщение № 1
Группа: Пользователи
Ранг: Прохожий
Сообщений: 5
Репутация: 0 ±
Замечаний: 0% ±

2016
Добрый день!
Помогите, пож, решить проблему - на одном листе в таблице есть 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]

заранее благодарю!

Автор - vitalik8307
Дата добавления - 29.04.2023 в 11:34
Pelena Дата: Суббота, 29.04.2023, 14:02 | Сообщение № 2
Группа: Админы
Ранг: Местный житель
Сообщений: 19235
Репутация: 4433 ±
Замечаний: ±

Excel 365 & Mac Excel
Здравствуйте.
Файла нет, проверить не на чем, принцип такой
[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]


"Черт возьми, Холмс! Но как??!!"
Ю-money 41001765434816
 
Ответить
СообщениеЗдравствуйте.
Файла нет, проверить не на чем, принцип такой
[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]

Автор - Pelena
Дата добавления - 29.04.2023 в 14:02
i691198 Дата: Воскресенье, 30.04.2023, 17:52 | Сообщение № 3
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 237
Репутация: 88 ±
Замечаний: 0% ±

Pelena, Вы почему то не обратили внимание, что макрос ТС одноразовый и просто его размножили, при первом добавлении нового значения в "список" оно добавится в строку ниже диапазона "перевозчик", а вот при следующем добавлении будет перезаписано предыдущее значение на новое. Целевой диапазон то не изменился. Конечно можно из целевых диапазонов сделать умные таблицы и изменить способ адресации, работать будет. Но для реальной работы это называется "через ж...", обычный пользователь не должен лезть в источники данных для списков. Если нужно добавить новые данные в списки, то это нужно делать в самой рабочей таблице. А вот тут и должен сработать макрос и спросить у пользователя -добавлять или нет это в справочник.
 
Ответить
СообщениеPelena, Вы почему то не обратили внимание, что макрос ТС одноразовый и просто его размножили, при первом добавлении нового значения в "список" оно добавится в строку ниже диапазона "перевозчик", а вот при следующем добавлении будет перезаписано предыдущее значение на новое. Целевой диапазон то не изменился. Конечно можно из целевых диапазонов сделать умные таблицы и изменить способ адресации, работать будет. Но для реальной работы это называется "через ж...", обычный пользователь не должен лезть в источники данных для списков. Если нужно добавить новые данные в списки, то это нужно делать в самой рабочей таблице. А вот тут и должен сработать макрос и спросить у пользователя -добавлять или нет это в справочник.

Автор - i691198
Дата добавления - 30.04.2023 в 17:52
Pelena Дата: Воскресенье, 30.04.2023, 19:32 | Сообщение № 4
Группа: Админы
Ранг: Местный житель
Сообщений: 19235
Репутация: 4433 ±
Замечаний: ±

Excel 365 & Mac Excel
нашёл один макрос - он работает, но только по одному списку - как его "размножить" на все три?
просто его размножили
всё строго по задаче

Целевой диапазон то не изменился
с чего Вы это взяли? А если это именованный диапазон умной таблицы? Файла-то нет


"Черт возьми, Холмс! Но как??!!"
Ю-money 41001765434816
 
Ответить
Сообщение
нашёл один макрос - он работает, но только по одному списку - как его "размножить" на все три?
просто его размножили
всё строго по задаче

Целевой диапазон то не изменился
с чего Вы это взяли? А если это именованный диапазон умной таблицы? Файла-то нет

Автор - Pelena
Дата добавления - 30.04.2023 в 19:32
i691198 Дата: Воскресенье, 30.04.2023, 20:18 | Сообщение № 5
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 237
Репутация: 88 ±
Замечаний: 0% ±

А если это именованный диапазон умной таблицы?

Ну да, вы как всегда правы, об этой многоходовке я не подумал.
 
Ответить
Сообщение
А если это именованный диапазон умной таблицы?

Ну да, вы как всегда правы, об этой многоходовке я не подумал.

Автор - i691198
Дата добавления - 30.04.2023 в 20:18
vitalik8307 Дата: Вторник, 02.05.2023, 11:19 | Сообщение № 6
Группа: Пользователи
Ранг: Прохожий
Сообщений: 5
Репутация: 0 ±
Замечаний: 0% ±

2016
Спасибо большое за отзывчивость - исправляюсь - прикладываю часть таблицы для которой и необходим данный макрос. (три нужных выпадающих списка выделил красным)
Спасибо за помощь!
К сообщению приложен файл: shablon_dlja_makrosa.xlsm (33.9 Kb)
 
Ответить
СообщениеСпасибо большое за отзывчивость - исправляюсь - прикладываю часть таблицы для которой и необходим данный макрос. (три нужных выпадающих списка выделил красным)
Спасибо за помощь!

Автор - vitalik8307
Дата добавления - 02.05.2023 в 11:19
Pelena Дата: Вторник, 02.05.2023, 16:50 | Сообщение № 7
Группа: Админы
Ранг: Местный житель
Сообщений: 19235
Репутация: 4433 ±
Замечаний: ±

Excel 365 & Mac Excel
В моём макросе просто надо имена заменить на актуальные
[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]
К сообщению приложен файл: 9304862.xlsm (33.6 Kb)


"Черт возьми, Холмс! Но как??!!"
Ю-money 41001765434816
 
Ответить
СообщениеВ моём макросе просто надо имена заменить на актуальные
[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]

Автор - Pelena
Дата добавления - 02.05.2023 в 16:50
vitalik8307 Дата: Вторник, 02.05.2023, 16:58 | Сообщение № 8
Группа: Пользователи
Ранг: Прохожий
Сообщений: 5
Репутация: 0 ±
Замечаний: 0% ±

2016
спасибо огромное!!!!!!!
 
Ответить
Сообщениеспасибо огромное!!!!!!!

Автор - vitalik8307
Дата добавления - 02.05.2023 в 16:58
  • Страница 1 из 1
  • 1
Поиск:

Яндекс.Метрика Яндекс цитирования
© 2010-2024 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!