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

Вход

Регистрация

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

 

= Мир MS Excel/Выделение и снятие выделения строки - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_  
Выделение и снятие выделения строки
4step Дата: Четверг, 30.03.2023, 15:37 | Сообщение № 1
Группа: Пользователи
Ранг: Участник
Сообщений: 85
Репутация: 0 ±
Замечаний: 40% ±

Добрый день! Имеется некий массив состоящий из произвольных цифр. Нужно командой выделить строку где имеется значение "100", а если значение "100" изменено на другое значение, то выделение строки нужно убрать при повторном запуске команды.
К сообщению приложен файл: primer2.xlsm (15.0 Kb)
 
Ответить
СообщениеДобрый день! Имеется некий массив состоящий из произвольных цифр. Нужно командой выделить строку где имеется значение "100", а если значение "100" изменено на другое значение, то выделение строки нужно убрать при повторном запуске команды.

Автор - 4step
Дата добавления - 30.03.2023 в 15:37
msi2102 Дата: Четверг, 30.03.2023, 17:54 | Сообщение № 2
Группа: Проверенные
Ранг: Обитатель
Сообщений: 415
Репутация: 129 ±
Замечаний: 0% ±

Excel 2007
Вставьте в начало такую строку
[vba]
Код
    Rows("1:16").Interior.Pattern = xlNone
[/vba]
 
Ответить
СообщениеВставьте в начало такую строку
[vba]
Код
    Rows("1:16").Interior.Pattern = xlNone
[/vba]

Автор - msi2102
Дата добавления - 30.03.2023 в 17:54
NikitaDvorets Дата: Пятница, 31.03.2023, 09:21 | Сообщение № 3
Группа: Авторы
Ранг: Ветеран
Сообщений: 604
Репутация: 137 ±
Замечаний: 0% ±

Excel 2019
4step,
Вариант: Worksheet_Change позволяет изменять 100 на другое значение без повторного запуска.
К сообщению приложен файл: test_283_highlightrowswithvalu.xlsm (20.4 Kb)
 
Ответить
Сообщение4step,
Вариант: Worksheet_Change позволяет изменять 100 на другое значение без повторного запуска.

Автор - NikitaDvorets
Дата добавления - 31.03.2023 в 09:21
msi2102 Дата: Пятница, 31.03.2023, 12:07 | Сообщение № 4
Группа: Проверенные
Ранг: Обитатель
Сообщений: 415
Репутация: 129 ±
Замечаний: 0% ±

Excel 2007
NikitaDvorets, я бы не много изменил Ваш код, а то при большом диапазоне, может здорово подтормаживать. Я бы не стал проверять весь диапазон, достаточно проверять одну строку в которой происходит изменение. Код мог бы выглядеть примерно так:
[vba]
Код
Public Sub Worksheet_Change(ByVal Target As Range)
    Dim rng As Range, n As Integer, arr
    Set rng = ActiveSheet.Range("A1:E16")
    If Not Intersect(Target, rng) Is Nothing Then
        arr = ActiveSheet.Range(Cells(Target.Row, "A"), Cells(Target.Row, "E"))
        For n = 1 To UBound(arr, 2)
            If arr(1, n) = 100 Then Target.EntireRow.Interior.Color = RGB(255, 165, 0): Exit Sub
        Next n
        Target.EntireRow.Interior.Pattern = xlNone
    End If
End Sub
[/vba]
Если всё таки нужно будет проверять весь диапазон, то я бы вначале очищал весь диапазон и лишь потом, т.к. потом в любом случае закрашиваете нужные строки, примерно так:
[vba]
Код
Public Sub Worksheet_Change(ByVal Target As Range)
    Dim rng As Range, n As Integer, m As Integer, arr
    Set rng = ActiveSheet.Range("A1:E16")
    rng.EntireRow.Interior.Pattern = xlNone
    If Not Intersect(Target, rng) Is Nothing Then
        arr = rng
        For m = 1 To UBound(arr)
            For n = 1 To UBound(arr, 2)
                If arr(m, n) = 100 Then Rows(m).EntireRow.Interior.Color = RGB(255, 165, 0): Exit For
            Next n
        Next m
    End If
End Sub
[/vba]
Ну а чтобы ещё увеличить скорость обработки можно использовать Union
[vba]
Код
Public Sub Worksheet_Change(ByVal Target As Range)
    Dim rng As Range, r As Range, n As Integer, m As Integer, arr
    Set rng = ActiveSheet.Range("A1:E16")
    rng.EntireRow.Interior.Pattern = xlNone
    If Not Intersect(Target, rng) Is Nothing Then
        arr = rng
        For m = 1 To UBound(arr)
            For n = 1 To UBound(arr, 2)
                If arr(m, n) = 100 Then
                    If r Is Nothing Then Set r = Rows(m) Else Set r = Union(r, Rows(m))
                    Exit For
                End If
            Next n
        Next m
        If Not r Is Nothing Then r.EntireRow.Interior.Color = RGB(255, 165, 0)
    End If
End Sub
[/vba]
К сообщению приложен файл: 5060094.xlsm (19.8 Kb)


Сообщение отредактировал msi2102 - Пятница, 31.03.2023, 12:36
 
Ответить
СообщениеNikitaDvorets, я бы не много изменил Ваш код, а то при большом диапазоне, может здорово подтормаживать. Я бы не стал проверять весь диапазон, достаточно проверять одну строку в которой происходит изменение. Код мог бы выглядеть примерно так:
[vba]
Код
Public Sub Worksheet_Change(ByVal Target As Range)
    Dim rng As Range, n As Integer, arr
    Set rng = ActiveSheet.Range("A1:E16")
    If Not Intersect(Target, rng) Is Nothing Then
        arr = ActiveSheet.Range(Cells(Target.Row, "A"), Cells(Target.Row, "E"))
        For n = 1 To UBound(arr, 2)
            If arr(1, n) = 100 Then Target.EntireRow.Interior.Color = RGB(255, 165, 0): Exit Sub
        Next n
        Target.EntireRow.Interior.Pattern = xlNone
    End If
End Sub
[/vba]
Если всё таки нужно будет проверять весь диапазон, то я бы вначале очищал весь диапазон и лишь потом, т.к. потом в любом случае закрашиваете нужные строки, примерно так:
[vba]
Код
Public Sub Worksheet_Change(ByVal Target As Range)
    Dim rng As Range, n As Integer, m As Integer, arr
    Set rng = ActiveSheet.Range("A1:E16")
    rng.EntireRow.Interior.Pattern = xlNone
    If Not Intersect(Target, rng) Is Nothing Then
        arr = rng
        For m = 1 To UBound(arr)
            For n = 1 To UBound(arr, 2)
                If arr(m, n) = 100 Then Rows(m).EntireRow.Interior.Color = RGB(255, 165, 0): Exit For
            Next n
        Next m
    End If
End Sub
[/vba]
Ну а чтобы ещё увеличить скорость обработки можно использовать Union
[vba]
Код
Public Sub Worksheet_Change(ByVal Target As Range)
    Dim rng As Range, r As Range, n As Integer, m As Integer, arr
    Set rng = ActiveSheet.Range("A1:E16")
    rng.EntireRow.Interior.Pattern = xlNone
    If Not Intersect(Target, rng) Is Nothing Then
        arr = rng
        For m = 1 To UBound(arr)
            For n = 1 To UBound(arr, 2)
                If arr(m, n) = 100 Then
                    If r Is Nothing Then Set r = Rows(m) Else Set r = Union(r, Rows(m))
                    Exit For
                End If
            Next n
        Next m
        If Not r Is Nothing Then r.EntireRow.Interior.Color = RGB(255, 165, 0)
    End If
End Sub
[/vba]

Автор - msi2102
Дата добавления - 31.03.2023 в 12:07
4step Дата: Пятница, 31.03.2023, 13:45 | Сообщение № 5
Группа: Пользователи
Ранг: Участник
Сообщений: 85
Репутация: 0 ±
Замечаний: 40% ±

msi2102, NikitaDvorets, Всем добрый день! Все замечательно работает.


Сообщение отредактировал 4step - Суббота, 01.04.2023, 10:20
 
Ответить
Сообщениеmsi2102, NikitaDvorets, Всем добрый день! Все замечательно работает.

Автор - 4step
Дата добавления - 31.03.2023 в 13:45
  • Страница 1 из 1
  • 1
Поиск:

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