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

Оффлайн Maximus80

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

Онлайн Администратор

  • Administrator
  • Сообщений: 1684
Макрос
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 подставьте нужную команду.

Оффлайн Maximus80

  • Посетитель форума
  • Сообщений: 3

Онлайн Администратор

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

Макрос
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

Оффлайн Maximus80

  • Посетитель форума
  • Сообщений: 3