Доброго времени суток уважаемые форумчане, появилась такая проблема, есть лист с данными "База", над данными строка с выпадающими списками, необходимо при выборе в выпадающем списке значения закрыт, разрывать все связи в столбце с данными в котором расположен выпадающий список, уже голову сломал, а всё никак не получается выделить диапазон данных под списком, замену формул на их значения для выбранного диапазона провести не проблема, а вот выбрать как не знаю. [p.s.]Заранее благодарю![/p.s.] [moder]А пример в файле?[/moder]
Доброго времени суток уважаемые форумчане, появилась такая проблема, есть лист с данными "База", над данными строка с выпадающими списками, необходимо при выборе в выпадающем списке значения закрыт, разрывать все связи в столбце с данными в котором расположен выпадающий список, уже голову сломал, а всё никак не получается выделить диапазон данных под списком, замену формул на их значения для выбранного диапазона провести не проблема, а вот выбрать как не знаю. [p.s.]Заранее благодарю![/p.s.] [moder]А пример в файле?[/moder]zshfan
Сообщение отредактировал _Boroda_ - Четверг, 24.03.2016, 14:34
Private Sub Worksheet_Change(ByVal Target As Range) With Target If .Count > 1 Then Exit Sub If .Row > 1 Then Exit Sub If .Value <> "закрыт" Then Exit Sub c_ = .Column r0_ = 2 r1_ = Cells(Rows.Count, c_).End(xlUp).Row Cells(r0_, c_).Resize(r1_ - r0_ + 1).Select End With End Sub
[/vba]
Выбрать вот так примерно можно. [vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range) With Target If .Count > 1 Then Exit Sub If .Row > 1 Then Exit Sub If .Value <> "закрыт" Then Exit Sub c_ = .Column r0_ = 2 r1_ = Cells(Rows.Count, c_).End(xlUp).Row Cells(r0_, c_).Resize(r1_ - r0_ + 1).Select End With End Sub
Private Sub Worksheet_Change(ByVal Target As Range) Set myRng = Intersect(Target, Rows(1)) If Not myRng Is Nothing Then For Each cell In myRng If cell.Value = "закрыт" Then _ Set res = Range(Cells(2, cell.Column), Cells(Rows.Count, cell.Column).End(xlUp)) res.Select 'выделяем Next cell End If End Sub
[/vba]
еще вариант: [vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range) Set myRng = Intersect(Target, Rows(1)) If Not myRng Is Nothing Then For Each cell In myRng If cell.Value = "закрыт" Then _ Set res = Range(Cells(2, cell.Column), Cells(Rows.Count, cell.Column).End(xlUp)) res.Select 'выделяем Next cell End If End Sub
Manyasha, Большое спасибо! сработал второй вариант. Правда при изменении на другое значение ячейка вываливается с ошибкой, но это решу просто обработчиком ошибок.
Manyasha, Большое спасибо! сработал второй вариант. Правда при изменении на другое значение ячейка вываливается с ошибкой, но это решу просто обработчиком ошибок.zshfan
Private Sub Worksheet_Change(ByVal Target As Range) On Error GoTo endMacro Dim myRng, cell, res As Range Set myRng = Intersect(Target, Rows(1)) If Not myRng Is Nothing Then For Each cell In myRng If cell.Value = "Закрыт" Then _ Set res = Range(Cells(4, cell.Column), Cells(Rows.Count, cell.Column).End(xlUp)) res.Select 'выделяем Selection.Copy Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False Range(Cells(1, cell.Column), Cells(1, cell.Column)).Select Next cell End If endMacro: End Sub
[/vba]
В итоге у меня получилось так:
[vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range) On Error GoTo endMacro Dim myRng, cell, res As Range Set myRng = Intersect(Target, Rows(1)) If Not myRng Is Nothing Then For Each cell In myRng If cell.Value = "Закрыт" Then _ Set res = Range(Cells(4, cell.Column), Cells(Rows.Count, cell.Column).End(xlUp)) res.Select 'выделяем Selection.Copy Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False Range(Cells(1, cell.Column), Cells(1, cell.Column)).Select Next cell End If endMacro: End Sub
Конечно не реагирует - у Вас его в файле просто нет. :D Ловите еще раз. Немного изменил там - высота считается по столбцу А И зачем Вам выделять-то? Вот так смотрите [vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range) With Target If .Count > 1 Then Exit Sub If .Row > 1 Then Exit Sub If .Value <> "Закрыт" Then Exit Sub c_ = .Column r0_ = 4 r1_ = Cells(Rows.Count, 1).End(xlUp).Row Cells(r0_, c_).Resize(r1_ - r0_ + 1) = Cells(r0_, c_).Resize(r1_ - r0_ + 1).Value End With End Sub
[/vba]
Конечно не реагирует - у Вас его в файле просто нет. :D Ловите еще раз. Немного изменил там - высота считается по столбцу А И зачем Вам выделять-то? Вот так смотрите [vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range) With Target If .Count > 1 Then Exit Sub If .Row > 1 Then Exit Sub If .Value <> "Закрыт" Then Exit Sub c_ = .Column r0_ = 4 r1_ = Cells(Rows.Count, 1).End(xlUp).Row Cells(r0_, c_).Resize(r1_ - r0_ + 1) = Cells(r0_, c_).Resize(r1_ - r0_ + 1).Value End With End Sub
Private Sub Worksheet_Change(ByVal Target As Range) If Target.Count > 1 Then Exit Sub If Not Application.Intersect(Range("J1:BK1"), Target) Is Nothing Then If Target <> "Закрыт" Then Exit Sub KL = Target.Column PS = Cells(Rows.Count, KL).End(xlUp).Row Application.EnableEvents = False Range(Cells(4, KL), Cells(PS, KL)).Value = Range(Cells(4, KL), Cells(PS, KL)).Value Application.EnableEvents = True End If End Sub
[/vba]
И так можно [vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range) If Target.Count > 1 Then Exit Sub If Not Application.Intersect(Range("J1:BK1"), Target) Is Nothing Then If Target <> "Закрыт" Then Exit Sub KL = Target.Column PS = Cells(Rows.Count, KL).End(xlUp).Row Application.EnableEvents = False Range(Cells(4, KL), Cells(PS, KL)).Value = Range(Cells(4, KL), Cells(PS, KL)).Value Application.EnableEvents = True End If End Sub
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
