Перебирайте ячейки, заполненные цветом, до тех пор, пока они не станут пустыми

Question

Я пытаюсь создать документ Excel, в котором я заполнил ячейки (соответствующее число ячеек отличается, некоторые только 1, другие 10+, столбцы имеют одинаковое число)

Я хочу сделатьвыбор "активной зоны".Так, например, если активной ячейкой является A11, то выбирается заполненная область от A11 и вплоть до E14 (все синие ячейки).

Это то, что я сейчас получил, я предполагаю, что мне нужен цикл while, ноЯ не могу заставить его работать:

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Target.Worksheet.Range("N5:N1000")) Is Nothing Then
        If Cells(Target.Row, 1).Interior.ColorIndex <> xlNone Then
            If Cells(Target.Row, 14) = "x" Or Cells(Target.Row, 14) = "X" Then
                         Range("A" & ActiveCell.Row).Select

            End If
        End If
   End If

End Sub

Лист Excel:

Шаг 1:

Шаг 2:

Шаг 3:

Answer 1

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

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim c As Range

    Set c = Application.Intersect(Target.Cells(1), Me.Range("N5:N1000"))

    If Not c Is Nothing Then
        If Me.Cells(c.Row, 1).Interior.ColorIndex <> xlNone And _
                        UCase(Me.Cells(Target.Row, 14)) = "X" Then

            GetColorBlock(Me.Cells(c.Row, 1)).Select

        End If
    End If

End Sub

'Expand a single cell range to all neighboring cells with the same fill color
'  (assumes colored range is rectangular)  
Function GetColorBlock(c As Range) As Range
    Dim tl As Range, br As Range, clr As Long
    clr = c.Interior.Color
    Set tl = c
    Set br = c
    Do While tl.Row > 1
        If tl.Offset(-1, 0).Interior.Color <> clr Then Exit Do
        Set tl = tl.Offset(-1, 0)
    Loop
    Do While tl.Column > 1
        If tl.Offset(0, -1).Interior.Color <> clr Then Exit Do
        Set tl = tl.Offset(0, -1)
    Loop
    Do While br.Row < Rows.Count
        If br.Offset(1, 0).Interior.Color <> clr Then Exit Do
        Set br = br.Offset(1, 0)
    Loop
    Do While br.Column < Columns.Count
        If br.Offset(0, 1).Interior.Color <> clr Then Exit Do
        Set br = br.Offset(0, 1)
    Loop
    Set GetColorBlock = c.Worksheet.Range(tl, br)
End Function