Поиск  Пользователи  Правила 
Закрыть
Логин:
Пароль:
Забыли свой пароль?
Регистрация
Войти
 
Страницы: 1
RSS
Автозаполнение диапазона столбцов после выбора из выпадающего списка
 
Доброго дня! Помогите в решении задачи.
Делаю форму запроса информации. Суть вопроса: при выборе должности из выпадающего списка справа от него и вниз должны заполниться значения из определенного перечня.  Файлик с комментариями во вложении. Можно через VBA.
Заранее спасибо.
 
сделать не сложно и формулой только вопрос зачем в столбце В в каждой ячейке выпадающий список
Лень двигатель прогресса, доказано!!!
 
На объект высылается пустая таблица. Работник из выпадающего списка выбирает должность и автоматически должны заполнится столбцы как после стрелки. Далее они указывают свои размеры и присылают на консолидацию. Должностей и сизов естественно будет больше.
 
вообщем всего глобального замысла не понял вот вариант
Лень двигатель прогресса, доказано!!!
 
Это не то. Т.к. в столбце В дальше из выпадающего списка нужно выбрать другие должности и так далее. Таблица идет с нарастанием вниз. Смысл в том, что бы на "том конце" не добавляли или не удаляли строки с нужной спецухой.
 
В файле как будет выглядеть заполнение. Столбцы Е-Н это образец как должно быть.
 
А база справа динамичная? Её будут менять, добавлять другие элементы "Спецухи" или статичная?
 
База скорее всего будет статичная (после заполнения ее).  
 
Код
Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Columns("E")) Is Nothing Then
        If Target.Cells.Count = 1 Then
            Select Case Target.Value
            Case ""
            Case Else
                Dim n As Long
                n = WorksheetFunction.CountIfs(ActiveSheet.ListObjects("Таблица1").DataBodyRange.Columns(1), Target.Value)
                
                If n > 0 Then
                    Dim y1 As Long
                    Dim y2 As Long
                    y1 = WorksheetFunction.Match(Target.Value, ActiveSheet.ListObjects("Таблица1").DataBodyRange.Columns(1), 0)
                    y2 = y1 + n - 1
                    
                    Dim a As Variant
                    With ActiveSheet.ListObjects("Таблица1").DataBodyRange
                        a = Range(.Cells(y1, 1), .Cells(y2, 2))
                    End With
                    
                    Application.EnableEvents = False
                        Target.Resize(UBound(a, 1), UBound(a, 2)) = a
                    Application.EnableEvents = True
                End If
            End Select
        End If
    End If
End Sub
 
МатросНаЗебре, то, что доктор прописал! Спасибо! А можно ли защитить эти ячейки от записи? Ну чтоб сначала выбрали и не смогли удалить строку.
 
Подскажите пожалуйста, как защитить добавленные строки.
 
Вопрос не  по теме
 
Код
Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Columns("E")) Is Nothing Then
        If Target.Cells.Count = 1 Then
            Select Case Target.Value
            Case ""
            Case Else
                Dim n As Long
                n = WorksheetFunction.CountIfs(ActiveSheet.ListObjects("Таблица1").DataBodyRange.Columns(1), Target.Value)
                
                If n > 0 Then
                    Dim y1 As Long
                    Dim y2 As Long
                    y1 = WorksheetFunction.Match(Target.Value, ActiveSheet.ListObjects("Таблица1").DataBodyRange.Columns(1), 0)
                    y2 = y1 + n - 1
                    
                    Dim a As Variant
                    With ActiveSheet.ListObjects("Таблица1").DataBodyRange
                        a = Range(.Cells(y1, 1), .Cells(y2, 2))
                    End With
                    
                    Application.EnableEvents = False
                    ActiveSheet.Unprotect
                        With Target.Resize(UBound(a, 1), UBound(a, 2))
                            .Cells = a
                            .Locked = True
                        End With
                    Application.EnableEvents = True
                    ActiveSheet.Protect
                End If
            End Select
        End If
    End If
End Sub
Защита добавленных ячеек.
 
МатросНаЗебре, спасибо, огромное. Все работает.
Страницы: 1
Читают тему (гостей: 1)
Наверх