CODEWITHSUNDEEP
excelvba
cpoulsen
cpoulsen

Reputation: 15

Loop through color filled cells until blank

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

Step 1:
enter image description here

Step 2:
enter image description here

Step 3:
enter image description here

Upvotes: 1

Views: 286

Answers (1)

Tim Williams
Tim Williams

Reputation: 166341

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

Upvotes: 4

Related Questions