Excel VBA Макросы: Макрос для выделения диапазона с учётом цветовой заливки.

Автор Maximum, 14 июля 2019, 16:16

Maximum

Необходим макрос для выделения диапазона в столбце А по условию: от первой ячейки после последней выделенной желтым цветом до последней заполненной ячейки в столбце.

[вложение удалено администратором]

Администратор

Макрос
Sub Макрос()

    Dim fr As Long, lr As Long, i As Long
   
   
    ' Поиск последней строки в столбце A.
        ' End не ищет в скрытых строках.
    lr = Cells(Rows.Count, "A").End(xlUp).Row
   
    ' Поиск жёлтой ячейки снизу вверх.
    For i = lr To 1 Step -1
        If Cells(i, "A").Interior.Color = 65535 Then
            fr = i + 1
            Exit For
        End If
    Next i
   
    ' Если нет жёлтых ячеек.
    If fr = 0 Then
        MsgBox "Жёлтых ячеек нет.", vbExclamation
        Exit Sub
    End If
   
    ' Выделение фрагмента.
    Columns("A").Rows(fr & ":" & lr).Select

End Sub
[свернуть]


Примечание

Вообще, выделять не всегда надо, чтобы что-то сделать. Достаточно просто обратиться к нужному фрагменту. То есть вместо Select подставьте нужную команду.


Администратор

Ещё вариант. Если первый способ будет работать долго, то можете попробовать этот способ.

Макрос
Sub Макрос()

    Dim fr As Long, lr As Long
   
   
    '1. Поиск жёлтой ячейки снизу вверх.
    '1) Сброс настроек оформления у поиска, которые может сделать юзер или другой макрос.
    Application.FindFormat.Clear
    '2) Настройка поиска. Поиск жёлтой заливки.
    Application.FindFormat.Interior.Color = 65535
    '3) Поиск. Окружаем поиск перехватчиком ошибок, чтобы макрос не остановился, если нет жёлтых ячеек.
    On Error Resume Next
    fr = Columns("A").Find(What:="*", LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, _
        MatchCase:=False, SearchFormat:=True).Row + 1
    On Error GoTo 0
    '4) Убираем настройки поиска, чтобы они не мешали юзеру.
        ' Настройки поиска видны в диалоге "Найти и заменить".
    Application.FindFormat.Clear
   
    '2. Если нет жёлтых ячеек.
    If fr = 0 Then
        MsgBox "Жёлтых ячеек нет.", vbExclamation
        Exit Sub
    End If
   
    '3. Поиск последней строки в столбце A.
        ' End не ищет в скрытых строках.
    lr = Cells(Rows.Count, "A").End(xlUp).Row
   
    '4. Выделение фрагмента.
    Columns("A").Rows(fr & ":" & lr).Select

End Sub
[свернуть]