Need help writing the code for an Excel Macro that would find all cells that
have any interior color so that an outer border can be added around all
colored cells.

Hi,

Try this. I've included the code to add the borders but you can delete this
if you want to do it manually. Not this will not work for conditionally
formatted coloured cells

Sub sonic()
Dim CopyRange As Range
For Each c In ActiveSheet.UsedRange
If c.Interior.ColorIndex < xlNone Then
If CopyRange Is Nothing Then
Set CopyRange = c
Else
Set CopyRange = Union(CopyRange, c)
End If
End If
Next

CopyRange.Select

'delete from here to end
'if you want to do the border manually

With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.Weight = xlMedium
End With
End Sub
--
Mike

When competing hypotheses are otherwise equal, adopt the hypothesis that
introduces the fewest assumptions while still sufficiently answering the
question.


"slb0927" wrote:

Need help writing the code for an Excel Macro that would find all cells that
have any interior color so that an outer border can be added around all
colored cells.

On Jan 31, 8:06*pm, slb0927 wrote:
Need help writing the code for an Excel Macro that would find all cells that
have any interior color so that an outer border can be added around all
colored cells.

If you adjust the range than the code below is simple and works.

Sub Select_Colored_Cells()

For r = 1 To 30
For k = 1 To 30

If Cells(r, k).Interior.ColorIndex < xlNone Then
Cells(r, k).Select
Selection.Borders(xlEdgeLeft).LineStyle = xlContinuous
Selection.Borders(xlEdgeTop).LineStyle = xlContinuous
Selection.Borders(xlEdgeBottom).LineStyle = xlContinuous
Selection.Borders(xlEdgeRight).LineStyle = xlContinuous
End If

Next k
Next r
End Sub

AWESOME! Just what I needed. The macro was needed because the borders would
not move with the colored cells when sorting the data. Your macro is much
more efficienct than the one I came up with. Thanks a million for the help!

"Mike H" wrote:

Hi,

Try this. I've included the code to add the borders but you can delete this
if you want to do it manually. Not this will not work for conditionally
formatted coloured cells

Sub sonic()
Dim CopyRange As Range
For Each c In ActiveSheet.UsedRange
If c.Interior.ColorIndex < xlNone Then
If CopyRange Is Nothing Then
Set CopyRange = c
Else
Set CopyRange = Union(CopyRange, c)
End If
End If
Next

CopyRange.Select

'delete from here to end
'if you want to do the border manually

With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.Weight = xlMedium
End With
End Sub
--
Mike

When competing hypotheses are otherwise equal, adopt the hypothesis that
introduces the fewest assumptions while still sufficiently answering the
question.


"slb0927" wrote:

Need help writing the code for an Excel Macro that would find all cells that
have any interior color so that an outer border can be added around all
colored cells.

That works except when there are consecutive cells with color. I prefer the
outer border for this exercise but will use this code in the future for other
worksheets. Thanks so much for taking the time to respond.

"Master Blaster" wrote:

On Jan 31, 8:06 pm, slb0927 wrote:
Need help writing the code for an Excel Macro that would find all cells that
have any interior color so that an outer border can be added around all
colored cells.

If you adjust the range than the code below is simple and works.

Sub Select_Colored_Cells()

For r = 1 To 30
For k = 1 To 30

If Cells(r, k).Interior.ColorIndex < xlNone Then
Cells(r, k).Select
Selection.Borders(xlEdgeLeft).LineStyle = xlContinuous
Selection.Borders(xlEdgeTop).LineStyle = xlContinuous
Selection.Borders(xlEdgeBottom).LineStyle = xlContinuous
Selection.Borders(xlEdgeRight).LineStyle = xlContinuous
End If

Next k
Next r
End Sub
.