Selecting cells by colour
 

How can I select in a worksheet only the cells which have a green background?

Selecting cells by colour
 

Sub sufgreen()
Set rr = Nothing
For Each r In ActiveSheet.UsedRange
If r.Interior.ColorIndex = 10 Then
If rr Is Nothing Then
Set rr = r
Else
Set rr = Union(rr, r)
End If
End If
Next
If Not rr Is Nothing Then
rr.Select
End If
End Sub
--
Gary''s Student - gsnu200733

Selecting cells by colour
 

Hey Gary, thanks a lot. It seems to work. Though, I will do some more testing
in order to be more sure.

"Gary''s Student" wrote:

Sub sufgreen()
Set rr = Nothing
For Each r In ActiveSheet.UsedRange
If r.Interior.ColorIndex = 10 Then
If rr Is Nothing Then
Set rr = r
Else
Set rr = Union(rr, r)
End If
End If
Next
If Not rr Is Nothing Then
rr.Select
End If
End Sub
--
Gary''s Student - gsnu200733

Selecting cells by colour
 

If you find a problem, let me know, and we will fix it together.
--
Gary''s Student - gsnu200733


"dspilberg" wrote:

Hey Gary, thanks a lot. It seems to work. Though, I will do some more testing
in order to be more sure.

"Gary''s Student" wrote:

Sub sufgreen()
Set rr = Nothing
For Each r In ActiveSheet.UsedRange
If r.Interior.ColorIndex = 10 Then
If rr Is Nothing Then
Set rr = r
Else
Set rr = Union(rr, r)
End If
End If
Next
If Not rr Is Nothing Then
rr.Select
End If
End Sub
--
Gary''s Student - gsnu200733

Selecting cells by colour
 

Is there any way to speed this up or perhaps a better way to go about it. I
have a table that utilizes 3 different colors. I need to bold outline around
each color group so I am searching for the first and last row of 1 color,
drawing my borders and then searching for the first and last row of a 2nd
color and drawing borders around it. It seems to go very, very slowly. The
colors will always be grouped together so the borders are not being drawn on
a row by row basis.

Thanks again for your help, Jeremiah

Sub FindColors()
Dim r As Range
Dim RR As Range
Set r = Nothing
For Each RR In ActiveSheet.UsedRange
If RR.Interior.ColorIndex = 35 Then
If r Is Nothing Then
Set r = RR
Else
Set r = Union(RR, r)
End If
End If
Next
If r Is Nothing Then
Else
r.Select
End If
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThick
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThick
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThick
.ColorIndex = xlAutomatic
End With
For Each RR In ActiveSheet.UsedRange
If RR.Interior.ColorIndex = 40 Then
If r Is Nothing Then
Set r = RR
Else
Set r = Union(RR, r)
End If
End If
Next
If r Is Nothing Then
Else
r.Select
End If
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThick
.ColorIndex = xlAutomatic
End With
End Sub


"Gary''s Student" wrote:

If you find a problem, let me know, and we will fix it together.
--
Gary''s Student - gsnu200733


"dspilberg" wrote:

Hey Gary, thanks a lot. It seems to work. Though, I will do some more testing
in order to be more sure.

"Gary''s Student" wrote:

Sub sufgreen()
Set rr = Nothing
For Each r In ActiveSheet.UsedRange
If r.Interior.ColorIndex = 10 Then
If rr Is Nothing Then
Set rr = r
Else
Set rr = Union(rr, r)
End If
End If
Next
If Not rr Is Nothing Then
rr.Select
End If
End Sub
--
Gary''s Student - gsnu200733

Selecting cells by colour
 

I have a bas file with lots of functions related to colors at
http://www.cpearson.com/Excel/Colors.aspx. You can use the
RangeOfColor function to return a Range object whose background or
font ColorIndex is some specific value and then draw the border around
the returned range. The code is explained on the page noted above, and
the downloadable module file is at
http://www.cpearson.com/Zips/modColorFunctions.zip .

Using RangeOfColor, you can use code like the following:

Sub AAA()
Dim R As Range

' Red
Set R = RangeOfColor(TestRange:=ActiveSheet.UsedRange, _
ColorIndex:=3, OfText:=False)
If Not R Is Nothing Then
R.BorderAround LineStyle:=xlSolid, Weight:=xlThick
End If

' Yellow
Set R = Nothing
Set R = RangeOfColor(TestRange:=ActiveSheet.UsedRange, _
ColorIndex:=6, OfText:=False)
If Not R Is Nothing Then
R.BorderAround LineStyle:=xlSolid, Weight:=xlThick
End If

' Blue
Set R = Nothing
Set R = RangeOfColor(TestRange:=ActiveSheet.UsedRange, _
ColorIndex:=5, OfText:=False)
If Not R Is Nothing Then
R.BorderAround LineStyle:=xlSolid, Weight:=xlThick
End If
End Sub


Cordially,
Chip Pearson
Microsoft MVP
Excel Product Group
Pearson Software Consulting, LLC
www.cpearson.com
(email on web site)



On Wed, 19 Nov 2008 05:41:02 -0800, jeremiah
wrote:

Is there any way to speed this up or perhaps a better way to go about it. I
have a table that utilizes 3 different colors. I need to bold outline around
each color group so I am searching for the first and last row of 1 color,
drawing my borders and then searching for the first and last row of a 2nd
color and drawing borders around it. It seems to go very, very slowly. The
colors will always be grouped together so the borders are not being drawn on
a row by row basis.

Thanks again for your help, Jeremiah

Sub FindColors()
Dim r As Range
Dim RR As Range
Set r = Nothing
For Each RR In ActiveSheet.UsedRange
If RR.Interior.ColorIndex = 35 Then
If r Is Nothing Then
Set r = RR
Else
Set r = Union(RR, r)
End If
End If
Next
If r Is Nothing Then
Else
r.Select
End If
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThick
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThick
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThick
.ColorIndex = xlAutomatic
End With
For Each RR In ActiveSheet.UsedRange
If RR.Interior.ColorIndex = 40 Then
If r Is Nothing Then
Set r = RR
Else
Set r = Union(RR, r)
End If
End If
Next
If r Is Nothing Then
Else
r.Select
End If
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThick
.ColorIndex = xlAutomatic
End With
End Sub


"Gary''s Student" wrote:

If you find a problem, let me know, and we will fix it together.
--
Gary''s Student - gsnu200733


"dspilberg" wrote:

Hey Gary, thanks a lot. It seems to work. Though, I will do some more testing
in order to be more sure.

"Gary''s Student" wrote:

Sub sufgreen()
Set rr = Nothing
For Each r In ActiveSheet.UsedRange
If r.Interior.ColorIndex = 10 Then
If rr Is Nothing Then
Set rr = r
Else
Set rr = Union(rr, r)
End If
End If
Next
If Not rr Is Nothing Then
rr.Select
End If
End Sub
--
Gary''s Student - gsnu200733