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

Вход

Регистрация

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

 

= Мир MS Excel/Подсветка активной строки другим цветом - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Подсветка активной строки другим цветом (Макросы/Sub)
Подсветка активной строки другим цветом
Liana88 Дата: Понедельник, 06.02.2017, 13:03 | Сообщение № 1
Группа: Пользователи
Ранг: Новичок
Сообщений: 19
Репутация: 0 ±
Замечаний: 0% ±

Excel 2003
Здравствуйте, нашла макрос для подсветки активной строки определенным цветом, проблема в том, что подсвечивается вся строка от А до горизонта и вторая проблема макроса в том, что если нажать на столбец, то всё дико зависает.
Прошу помочь изменить макрос таким образом, чтобы при нажатии на ячейку в строке подсвечивались ячейки с 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]


Сообщение отредактировал Liana88 - Понедельник, 06.02.2017, 13:03
 
Ответить
СообщениеЗдравствуйте, нашла макрос для подсветки активной строки определенным цветом, проблема в том, что подсвечивается вся строка от А до горизонта и вторая проблема макроса в том, что если нажать на столбец, то всё дико зависает.
Прошу помочь изменить макрос таким образом, чтобы при нажатии на ячейку в строке подсвечивались ячейки с 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]

Автор - Liana88
Дата добавления - 06.02.2017 в 13:03
Manyasha Дата: Понедельник, 06.02.2017, 13:15 | Сообщение № 2
Группа: Модераторы
Ранг: Старожил
Сообщений: 2198
Репутация: 898 ±
Замечаний: 0% ±

Excel 2010, 2016
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

Set rn_Prev = Target

End Sub
[/vba]


ЯД: 410013299366744 WM: R193491431804
 
Ответить
Сообщение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

Set rn_Prev = Target

End Sub
[/vba]

Автор - Manyasha
Дата добавления - 06.02.2017 в 13:15
Liana88 Дата: Понедельник, 06.02.2017, 13:20 | Сообщение № 3
Группа: Пользователи
Ранг: Новичок
Сообщений: 19
Репутация: 0 ±
Замечаний: 0% ±

Excel 2003
Manyasha, можно, пожалуйста, поправить, чтобы если происходит выход за пределы столбца "О", то он не оставляет цветастую полосу после себя?
 
Ответить
СообщениеManyasha, можно, пожалуйста, поправить, чтобы если происходит выход за пределы столбца "О", то он не оставляет цветастую полосу после себя?

Автор - Liana88
Дата добавления - 06.02.2017 в 13:20
Manyasha Дата: Понедельник, 06.02.2017, 13:39 | Сообщение № 4
Группа: Модераторы
Ранг: Старожил
Сообщений: 2198
Репутация: 898 ±
Замечаний: 0% ±

Excel 2010, 2016
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]

Код немного сократила, т.к. циклы не нужны, если мы красим только по одной строке.


ЯД: 410013299366744 WM: R193491431804
 
Ответить
Сообщение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
Дата добавления - 06.02.2017 в 13:39
Liana88 Дата: Понедельник, 06.02.2017, 13:52 | Сообщение № 5
Группа: Пользователи
Ранг: Новичок
Сообщений: 19
Репутация: 0 ±
Замечаний: 0% ±

Excel 2003
Manyasha, спасибо огромнейшее, всё идеально работает.
 
Ответить
СообщениеManyasha, спасибо огромнейшее, всё идеально работает.

Автор - Liana88
Дата добавления - 06.02.2017 в 13:52
exzor Дата: Среда, 07.08.2019, 17:34 | Сообщение № 6
Группа: Пользователи
Ранг: Прохожий
Сообщений: 5
Репутация: 0 ±
Замечаний: 0% ±

Excel 2016
Manyasha а скажите пожалуйста как сделать так что бы закрашенные области не снималась после того как на них попадает макрос?
 
Ответить
СообщениеManyasha а скажите пожалуйста как сделать так что бы закрашенные области не снималась после того как на них попадает макрос?

Автор - exzor
Дата добавления - 07.08.2019 в 17:34
китин Дата: Четверг, 08.08.2019, 08:25 | Сообщение № 7
Группа: Модераторы
Ранг: Экселист
Сообщений: 7013
Репутация: 1073 ±
Замечаний: 0% ±

Excel 2007;2010;2016
что бы закрашенные области не снималась после того как на них попадает макрос?

это как? можно поподробнее....
а если хотите, что бы окраска ячеек просто оставалась, то уберите из макроса эту часть
[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]


Не судите очень строго:я пытаюсь научиться
ЯД 41001877306852
 
Ответить
Сообщение
что бы закрашенные области не снималась после того как на них попадает макрос?

это как? можно поподробнее....
а если хотите, что бы окраска ячеек просто оставалась, то уберите из макроса эту часть
[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]

Автор - китин
Дата добавления - 08.08.2019 в 08:25
exzor Дата: Среда, 21.08.2019, 17:39 | Сообщение № 8
Группа: Пользователи
Ранг: Прохожий
Сообщений: 5
Репутация: 0 ±
Замечаний: 0% ±

Excel 2016
ну вот пример первый пока макрос не сработал а второй когда включился



 
Ответить
Сообщениену вот пример первый пока макрос не сработал а второй когда включился




Автор - exzor
Дата добавления - 21.08.2019 в 17:39
китин Дата: Четверг, 22.08.2019, 08:48 | Сообщение № 9
Группа: Модераторы
Ранг: Экселист
Сообщений: 7013
Репутация: 1073 ±
Замечаний: 0% ±

Excel 2007;2010;2016
exzor, - Прочитайте Правила форума

- Приложите файл с исходными данными и желаемым результатом (можно вручную) в формате Excel размером до 100кб согласно п.3 Правил форума


Не судите очень строго:я пытаюсь научиться
ЯД 41001877306852


Сообщение отредактировал китин - Четверг, 22.08.2019, 13:30
 
Ответить
Сообщениеexzor, - Прочитайте Правила форума

- Приложите файл с исходными данными и желаемым результатом (можно вручную) в формате Excel размером до 100кб согласно п.3 Правил форума

Автор - китин
Дата добавления - 22.08.2019 в 08:48
exzor Дата: Среда, 25.09.2019, 16:34 | Сообщение № 10
Группа: Пользователи
Ранг: Прохожий
Сообщений: 5
Репутация: 0 ±
Замечаний: 0% ±

Excel 2016
нет все равно не получается удалив строчки о которых вы сказали.
у меня на первом скриншоте залиты области мне надо чтоб они также оставались после того как я перемещусь по ячейкам
а получается что либо все области снимется окрас остается либо на оборот увеличиваеться дополнительными строками

если описать проблему то она такая в файле пример одной из таблиц у нас 4000 сотрудников. ведя поиск по таб. номеру мне нужно значение поставить в столбик который за экраном ведя прокрутку сбиваешься со строчки.

так вот я пытаюсь написать макрос который подсветит всю строку по выделенной ячейке, но не будет снимать уже закрашенные области
К сообщению приложен файл: 4565139.xlsx (10.4 Kb)


Сообщение отредактировал exzor - Среда, 25.09.2019, 17:38
 
Ответить
Сообщениенет все равно не получается удалив строчки о которых вы сказали.
у меня на первом скриншоте залиты области мне надо чтоб они также оставались после того как я перемещусь по ячейкам
а получается что либо все области снимется окрас остается либо на оборот увеличиваеться дополнительными строками

если описать проблему то она такая в файле пример одной из таблиц у нас 4000 сотрудников. ведя поиск по таб. номеру мне нужно значение поставить в столбик который за экраном ведя прокрутку сбиваешься со строчки.

так вот я пытаюсь написать макрос который подсветит всю строку по выделенной ячейке, но не будет снимать уже закрашенные области

Автор - exzor
Дата добавления - 25.09.2019 в 16:34
Alex_ST Дата: Четверг, 26.09.2019, 15:32 | Сообщение № 11
Группа: Друзья
Ранг: Участник клуба
Сообщений: 3198
Репутация: 606 ±
Замечаний: 0% ±

2003
А может Вам какой-нибудь из типов Координатного выделения попробовать?
В больших таблицах достаточно удобно.



С уважением,
Алексей
MS Excel 2003 - the best!!!
 
Ответить
СообщениеА может Вам какой-нибудь из типов Координатного выделения попробовать?
В больших таблицах достаточно удобно.

Автор - Alex_ST
Дата добавления - 26.09.2019 в 15:32
exzor Дата: Четверг, 26.09.2019, 17:25 | Сообщение № 12
Группа: Пользователи
Ранг: Прохожий
Сообщений: 5
Репутация: 0 ±
Замечаний: 0% ±

Excel 2016
я пробовал 1 сильно грузит, 4 не подходит так как указывает перекрестие а надо чтобы выбрав ячейка подсвечивалась строка и промотав несколько экранов я в нужной строке подставил нужное значение, условное форматирование я пробовал но было другая формула она не заработала с 3 вариантом я по пробую

СПАСИБО
 
Ответить
Сообщениея пробовал 1 сильно грузит, 4 не подходит так как указывает перекрестие а надо чтобы выбрав ячейка подсвечивалась строка и промотав несколько экранов я в нужной строке подставил нужное значение, условное форматирование я пробовал но было другая формула она не заработала с 3 вариантом я по пробую

СПАСИБО

Автор - exzor
Дата добавления - 26.09.2019 в 17:25
Alex_ST Дата: Пятница, 27.09.2019, 12:41 | Сообщение № 13
Группа: Друзья
Ранг: Участник клуба
Сообщений: 3198
Репутация: 606 ±
Замечаний: 0% ±

2003
Я с работы, к сожалению, не могу выкладывать файлы с макросами (сисадмины - собаки параноидальные!)
Попробуйте на новом листе создать именованный диапазон с именем 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]



С уважением,
Алексей
MS Excel 2003 - the best!!!
 
Ответить
СообщениеЯ с работы, к сожалению, не могу выкладывать файлы с макросами (сисадмины - собаки параноидальные!)
Попробуйте на новом листе создать именованный диапазон с именем 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]

Автор - Alex_ST
Дата добавления - 27.09.2019 в 12:41
Alex_ST Дата: Пятница, 27.09.2019, 14:40 | Сообщение № 14
Группа: Друзья
Ранг: Участник клуба
Сообщений: 3198
Репутация: 606 ±
Замечаний: 0% ±

2003
К стати, попробовал я описанный Игорем Способ 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, для того, чтобы можно было управлять включением/выключением функции.



С уважением,
Алексей
MS Excel 2003 - the best!!!
 
Ответить
СообщениеК стати, попробовал я описанный Игорем Способ 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
Дата добавления - 27.09.2019 в 14:40
exzor Дата: Среда, 16.10.2019, 17:36 | Сообщение № 15
Группа: Пользователи
Ранг: Прохожий
Сообщений: 5
Репутация: 0 ±
Замечаний: 0% ±

Excel 2016
Доброго времени суток

Сделал как описано, пишет что у меня ошибка и указывает на это место If Me.CheckBoxes("FLAG") <> в обоих вариантах
 
Ответить
СообщениеДоброго времени суток

Сделал как описано, пишет что у меня ошибка и указывает на это место If Me.CheckBoxes("FLAG") <> в обоих вариантах

Автор - exzor
Дата добавления - 16.10.2019 в 17:36
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Подсветка активной строки другим цветом (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

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