Здравствуйте, нашла макрос для подсветки активной строки определенным цветом, проблема в том, что подсвечивается вся строка от А до горизонта и вторая проблема макроса в том, что если нажать на столбец, то всё дико зависает. Прошу помочь изменить макрос таким образом, чтобы при нажатии на ячейку в строке подсвечивались ячейки с A-O и влияла только на строку, а не на столбцы.
[vba]
Код
Private Sub Worksheet_SelectionChange(ByVal Target As Range) Static rn_Prev As Range Dim rn As Range
If rn_Prev Is Nothing Then Cells.Interior.ColorIndex = xlColorIndexNone Else For Each rn In rn_Prev If rn.Interior.ColorIndex <> xlColorIndexNone Then _ rn.EntireRow.Interior.ColorIndex = xlColorIndexNone Next End If
For Each rn In Target If rn.Interior.ColorIndex <> 37 Then rn.EntireRow.Interior.ColorIndex = 37 Next
Set rn_Prev = Target
End Sub
[/vba]
Здравствуйте, нашла макрос для подсветки активной строки определенным цветом, проблема в том, что подсвечивается вся строка от А до горизонта и вторая проблема макроса в том, что если нажать на столбец, то всё дико зависает. Прошу помочь изменить макрос таким образом, чтобы при нажатии на ячейку в строке подсвечивались ячейки с A-O и влияла только на строку, а не на столбцы.
[vba]
Код
Private Sub Worksheet_SelectionChange(ByVal Target As Range) Static rn_Prev As Range Dim rn As Range
If rn_Prev Is Nothing Then Cells.Interior.ColorIndex = xlColorIndexNone Else For Each rn In rn_Prev If rn.Interior.ColorIndex <> xlColorIndexNone Then _ rn.EntireRow.Interior.ColorIndex = xlColorIndexNone Next End If
For Each rn In Target If rn.Interior.ColorIndex <> 37 Then rn.EntireRow.Interior.ColorIndex = 37 Next
Private Sub Worksheet_SelectionChange(ByVal Target As Range) 'Если выделено больше 1-й строки, то выходим из макроса If Target.Rows.Count > 1 Then Exit Sub Static rn_Prev As Range Dim rn As Range
If rn_Prev Is Nothing Then Cells.Interior.ColorIndex = xlColorIndexNone Else For Each rn In rn_Prev If rn.Interior.ColorIndex <> xlColorIndexNone Then _ rn.EntireRow.Interior.ColorIndex = xlColorIndexNone Next End If
For Each rn In Target 'вместо всей строки (rn.EntireRow) закрашиваем диапазон а:о If rn.Interior.ColorIndex <> 37 Then Range("a" & rn.Row & ":o" & rn.Row).Interior.ColorIndex = 37 Next
Set rn_Prev = Target
End Sub
[/vba]
Liana88, здравствуйте, попробуйте так: [vba]
Код
Private Sub Worksheet_SelectionChange(ByVal Target As Range) 'Если выделено больше 1-й строки, то выходим из макроса If Target.Rows.Count > 1 Then Exit Sub Static rn_Prev As Range Dim rn As Range
If rn_Prev Is Nothing Then Cells.Interior.ColorIndex = xlColorIndexNone Else For Each rn In rn_Prev If rn.Interior.ColorIndex <> xlColorIndexNone Then _ rn.EntireRow.Interior.ColorIndex = xlColorIndexNone Next End If
For Each rn In Target 'вместо всей строки (rn.EntireRow) закрашиваем диапазон а:о If rn.Interior.ColorIndex <> 37 Then Range("a" & rn.Row & ":o" & rn.Row).Interior.ColorIndex = 37 Next
Private Sub Worksheet_SelectionChange(ByVal Target As Range) 'Если выделено больше 1-й строки, то выходим из макроса If Target.Rows.Count > 1 Then Exit Sub 'Если выделяем столбец за пределами А:О, закрашивать строку нужно? 'Если нет, то расскомментировать следующую строчку 'If Target.Column > 15 Then Exit Sub Static rn_Prev As Range Dim rn As Range
If rn_Prev Is Nothing Then Cells.Interior.ColorIndex = xlColorIndexNone Else Range("a" & rn_Prev.Row & ":o" & rn_Prev.Row).Interior.ColorIndex = xlColorIndexNone End If 'вместо всей строки (rn.EntireRow) закрашиваем диапазон а:о Range("a" & Target.Row & ":o" & Target.Row).Interior.ColorIndex = 37 Set rn_Prev = Target
End Sub
[/vba]
Код немного сократила, т.к. циклы не нужны, если мы красим только по одной строке.
Liana88, пробуйте: [vba]
Код
Private Sub Worksheet_SelectionChange(ByVal Target As Range) 'Если выделено больше 1-й строки, то выходим из макроса If Target.Rows.Count > 1 Then Exit Sub 'Если выделяем столбец за пределами А:О, закрашивать строку нужно? 'Если нет, то расскомментировать следующую строчку 'If Target.Column > 15 Then Exit Sub Static rn_Prev As Range Dim rn As Range
If rn_Prev Is Nothing Then Cells.Interior.ColorIndex = xlColorIndexNone Else Range("a" & rn_Prev.Row & ":o" & rn_Prev.Row).Interior.ColorIndex = xlColorIndexNone End If 'вместо всей строки (rn.EntireRow) закрашиваем диапазон а:о Range("a" & Target.Row & ":o" & Target.Row).Interior.ColorIndex = 37 Set rn_Prev = Target
End Sub
[/vba]
Код немного сократила, т.к. циклы не нужны, если мы красим только по одной строке.Manyasha
что бы закрашенные области не снималась после того как на них попадает макрос?
это как? можно поподробнее.... а если хотите, что бы окраска ячеек просто оставалась, то уберите из макроса эту часть [vba]
Код
If rn_Prev Is Nothing Then Cells.Interior.ColorIndex = xlColorIndexNone Else Range("a" & rn_Prev.Row & ":o" & rn_Prev.Row).Interior.ColorIndex = xlColorIndexNone End If
что бы закрашенные области не снималась после того как на них попадает макрос?
это как? можно поподробнее.... а если хотите, что бы окраска ячеек просто оставалась, то уберите из макроса эту часть [vba]
Код
If rn_Prev Is Nothing Then Cells.Interior.ColorIndex = xlColorIndexNone Else Range("a" & rn_Prev.Row & ":o" & rn_Prev.Row).Interior.ColorIndex = xlColorIndexNone End If
нет все равно не получается удалив строчки о которых вы сказали. у меня на первом скриншоте залиты области мне надо чтоб они также оставались после того как я перемещусь по ячейкам а получается что либо все области снимется окрас остается либо на оборот увеличиваеться дополнительными строками
если описать проблему то она такая в файле пример одной из таблиц у нас 4000 сотрудников. ведя поиск по таб. номеру мне нужно значение поставить в столбик который за экраном ведя прокрутку сбиваешься со строчки.
так вот я пытаюсь написать макрос который подсветит всю строку по выделенной ячейке, но не будет снимать уже закрашенные области
нет все равно не получается удалив строчки о которых вы сказали. у меня на первом скриншоте залиты области мне надо чтоб они также оставались после того как я перемещусь по ячейкам а получается что либо все области снимется окрас остается либо на оборот увеличиваеться дополнительными строками
если описать проблему то она такая в файле пример одной из таблиц у нас 4000 сотрудников. ведя поиск по таб. номеру мне нужно значение поставить в столбик который за экраном ведя прокрутку сбиваешься со строчки.
так вот я пытаюсь написать макрос который подсветит всю строку по выделенной ячейке, но не будет снимать уже закрашенные областиexzor
я пробовал 1 сильно грузит, 4 не подходит так как указывает перекрестие а надо чтобы выбрав ячейка подсвечивалась строка и промотав несколько экранов я в нужной строке подставил нужное значение, условное форматирование я пробовал но было другая формула она не заработала с 3 вариантом я по пробую
СПАСИБО
я пробовал 1 сильно грузит, 4 не подходит так как указывает перекрестие а надо чтобы выбрав ячейка подсвечивалась строка и промотав несколько экранов я в нужной строке подставил нужное значение, условное форматирование я пробовал но было другая формула она не заработала с 3 вариантом я по пробую
Я с работы, к сожалению, не могу выкладывать файлы с макросами (сисадмины - собаки параноидальные!) Попробуйте на новом листе создать именованный диапазон с именем RRR и для наглядности обведите его рамкой. Кроме того добавьте на лист элемент управления форм "Флажок", дайте ему имя FLAG и для наглядности присвойте капчу, например, "Закраска" (так Вы сможете управлять включением/выключением функции. В модуль листа добавьте код: [vba]
Код
Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Me.CheckBoxes("FLAG") <> 1 Then Exit Sub If Not Intersect(Target, [RRR]) Is Nothing Then With Application: .EnableEvents = False: .Calculation = xlManual: End With ActiveSheet.[RRR].Interior.ColorIndex = xlNone With Target Intersect(.EntireRow, [RRR]).Interior.ColorIndex = 6: .Activate ' для выделения строки ' Union(Intersect(.EntireRow, [RRR]), Intersect(.EntireColumn, [RRR])).Interior.ColorIndex = 6: .Activate' для координатного выделения End With With Application: .EnableEvents = True: .Calculation = xlAutomatic: End With End If End Sub
[/vba]
Я с работы, к сожалению, не могу выкладывать файлы с макросами (сисадмины - собаки параноидальные!) Попробуйте на новом листе создать именованный диапазон с именем RRR и для наглядности обведите его рамкой. Кроме того добавьте на лист элемент управления форм "Флажок", дайте ему имя FLAG и для наглядности присвойте капчу, например, "Закраска" (так Вы сможете управлять включением/выключением функции. В модуль листа добавьте код: [vba]
Код
Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Me.CheckBoxes("FLAG") <> 1 Then Exit Sub If Not Intersect(Target, [RRR]) Is Nothing Then With Application: .EnableEvents = False: .Calculation = xlManual: End With ActiveSheet.[RRR].Interior.ColorIndex = xlNone With Target Intersect(.EntireRow, [RRR]).Interior.ColorIndex = 6: .Activate ' для выделения строки ' Union(Intersect(.EntireRow, [RRR]), Intersect(.EntireColumn, [RRR])).Interior.ColorIndex = 6: .Activate' для координатного выделения End With With Application: .EnableEvents = True: .Calculation = xlAutomatic: End With End If End Sub
К стати, попробовал я описанный Игорем Способ 3. Оптимальный. Условное форматирование + макросы Очень понравилось! Чуть подпилил для упрощения и утащил к себе в копилку. Для Ваших требований - выделения не перекрестия, а строки - процедура будет выглядеть так:[vba]
Код
Private Sub Worksheet_SelectionChange(ByVal Target As Range) ' If Target.Count > 1 Then Exit Sub ' для выделения только одной ячейки If Me.CheckBoxes("FLAG") <> 1 Then: [RRR].FormatConditions.Delete: Exit Sub Application.EnableEvents = False If Not Intersect(Target, [RRR]) Is Nothing Then [RRR].FormatConditions.Delete With Intersect([RRR], Target.EntireRow) ' для выделения строки ' With Intersect([RRR], Union(Target.EntireRow, Target.EntireColumn))' для выделения креста .FormatConditions.Add Type:=xlExpression, Formula1:="=1" .FormatConditions(1).Interior.ColorIndex = 33 End With ' Target.FormatConditions.Delete End If Application.EnableEvents = True End Sub
[/vba]Только не забудьте как и в предыдущем варианте создать на листе именованный диапазон с именем RRR и добавить на лист элемент управления форм "Флажок", дав ему имя FLAG, для того, чтобы можно было управлять включением/выключением функции.
К стати, попробовал я описанный Игорем Способ 3. Оптимальный. Условное форматирование + макросы Очень понравилось! Чуть подпилил для упрощения и утащил к себе в копилку. Для Ваших требований - выделения не перекрестия, а строки - процедура будет выглядеть так:[vba]
Код
Private Sub Worksheet_SelectionChange(ByVal Target As Range) ' If Target.Count > 1 Then Exit Sub ' для выделения только одной ячейки If Me.CheckBoxes("FLAG") <> 1 Then: [RRR].FormatConditions.Delete: Exit Sub Application.EnableEvents = False If Not Intersect(Target, [RRR]) Is Nothing Then [RRR].FormatConditions.Delete With Intersect([RRR], Target.EntireRow) ' для выделения строки ' With Intersect([RRR], Union(Target.EntireRow, Target.EntireColumn))' для выделения креста .FormatConditions.Add Type:=xlExpression, Formula1:="=1" .FormatConditions(1).Interior.ColorIndex = 33 End With ' Target.FormatConditions.Delete End If Application.EnableEvents = True End Sub
[/vba]Только не забудьте как и в предыдущем варианте создать на листе именованный диапазон с именем RRR и добавить на лист элемент управления форм "Флажок", дав ему имя FLAG, для того, чтобы можно было управлять включением/выключением функции.Alex_ST
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
