Macro to apply a border to coloured cells

[rubenovik]

I have a sheet that has cells colloured in an uneven way.

http://cid-d455ddfd848f43ef.office.live.com/browse.aspx/.Public

Is it possible to run a macro that can detect the color of a cell or group of cells and apply a border to it?

In the sample the cells above are the original and those below are the result needed.

Thanks,

Alexei

 

[Weaver]

Are the cells actually coloured, or is the colour the result of conditional formatting? If the latter, you'll need to set the border as part of the formatting. Otherwise what you need can be done in code.

 

[Krishnakumar]

Hi,

Try

Sub kTest()
    Dim rngColor    As Range
    Dim i   As Long, j As Long
    
    Set rngColor = Range("b2:h7")
    Application.ScreenUpdating = 0
    With rngColor
        For i = .Rows.Count To 1 Step -1
            For j = .Columns.Count - 1 To 1 Step -1
                If .Cells(i, j).Interior.Color = .Cells(i, j + 1).Interior.Color Then
                    .Cells(i, j).Resize(, 2).Merge
                    .Cells(i, j).MergeArea.BorderAround 1, 3
                Else
                    .Cells(i, j).BorderAround 1, 3
                End If
            Next
        Next
        .UnMerge
        .BorderAround 1, 3
    End With
    Application.ScreenUpdating = 1
End Sub

HTH

 

[Weaver]

try:

Sub colouredCells()
    Dim r, c, t, i, rng
    Set rng = Range("B2:H7") 'set this to the area your cells are in (doesn't have to be exact)
    Application.ScreenUpdating = 0
    With rng
        For r = 1 To .Rows.Count
            For c = 1 To .Cells.Count
                If .Cells(r, c).Interior.ColorIndex <> xlNone Then
                    t = c
                    Do
                        t = t + 1
                    Loop Until .Cells(r, t).Interior.ColorIndex <> .Cells(r, c).Interior.ColorIndex Or t >= .Cells.Count
                    With .Cells(r, c).Resize(, t - c)
                        For i = 7 To 10
                            With .Borders(i)
                                .LineStyle = xlContinuous
                                .Weight = xlMedium
                            End With
                        Next i
                    End With
                    c = t - 1
                End If
            Next c
        Next r
    End With
            
End Sub

 

[rubenovik]

Krishnakumar:
Sorry I didnt explained myself better. Your macro worked great for that specific range of cells. Although... I forgot to mention that there were separate clusters of coloured cells in the same sheet. So I went ahead and tried Weaver's macro which worked exactly the way I needed.

Weaver:
I get a report where the cells are already coloured.
Thank you very much for the help. Your macro worked like a charm.

Alexei