Loop through color filled cells until blank

Question

I'm trying to create an Excel document where I have filled cells (the related number of cells is different, some only 1 others 10+, columns are the same number)

I want to make a selection of "activeCell area". So e.g. if the active cell is A11 then the filled area from A11 and all the way to E14 is selected (all blue cells).

This is what I currently got, I assume I need a while loop, but I can't get it to work:

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 sheet:

Step 1:

Step 2:

Step 3:

It's not clear what the role of "x" is here... Also your code looks like code from an event handler - is it? — Tim Williams
When the user make an x in column 14 in same row as a blue one, I want to select all of the "filled" cells which are touching each other and cut them to another sheet. — cpoulsen
Step 1 i.stack.imgur.com/tH0Pi.png Step 2 i.stack.imgur.com/9UAk0.png Step 3 i.stack.imgur.com/mCWNR.png I really just need a way to select the area — cpoulsen

Tim Williams Tim Williams · Accepted Answer · 2018-10-10T06:24:38

If you want to expand a single-cell range to cover a rectangular range of the same fill you can do something like:

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

Loop through color filled cells until blank

1 Answers