Complicated Code

[Bob]

I have written some code that allow me to display a rectangle around
certain scores within my worksheet. My code fomats the rectangle with
black lines if a specific condition is met and with transparent lines
if the condition is not met. My problem is I have about 50 rectangles
within my work sheet and the code I have written address each
rectangel indvidually. I would appreciate it if someone could offer a
suggesting on improving the code. Thanks in advance


'Code for 2 of the 50 rectangles
Sub Insert_Box136()
Sheets("T7").Select
If Range("R8").Value = 0 Then

'Turn rectangle off
ActiveSheet.Shapes("Rectangle 136").Select
Selection.ShapeRange.Fill.Visible = msoFalse
Selection.ShapeRange.Fill.Transparency = 0.5
Selection.ShapeRange.Line.Weight = 1.75
Selection.ShapeRange.Line.DashStyle = msoLineSolid
Selection.ShapeRange.Line.Style = msoLineSingle
Selection.ShapeRange.Line.Transparency = 0#
Selection.ShapeRange.Line.Visible = msoFalse


End If
If Range("R8").Value = 1 Then

'Turn rectangle on
ActiveSheet.Shapes("Rectangle 136").Select
Selection.ShapeRange.Fill.Visible = msoFalse
Selection.ShapeRange.Fill.Transparency = 0.5
Selection.ShapeRange.Line.Weight = 1.75
Selection.ShapeRange.Line.DashStyle = msoLineSolid
Selection.ShapeRange.Line.Style = msoLineSingle
Selection.ShapeRange.Line.Transparency = 0#
Selection.ShapeRange.Line.Visible = msoTrue
Selection.ShapeRange.Line.ForeColor.SchemeColor = 64
Selection.ShapeRange.Line.BackColor.RGB = RGB(255, 255, 255)




End If
End Sub




Sub Insert_Box137()
'

If Range("R9").Value = 0 Then

'Turn Box off
ActiveSheet.Shapes("Rectangle 137").Select
Selection.ShapeRange.Fill.Visible = msoFalse
Selection.ShapeRange.Fill.Transparency = 0.5
Selection.ShapeRange.Line.Weight = 1.75
Selection.ShapeRange.Line.DashStyle = msoLineSolid
Selection.ShapeRange.Line.Style = msoLineSingle
Selection.ShapeRange.Line.Transparency = 0#
Selection.ShapeRange.Line.Visible = msoFalse


End If
If Range("R9").Value = 1 Then

'Turn rectangle on
ActiveSheet.Shapes("Rectangle 137").Select
Selection.ShapeRange.Fill.Visible = msoFalse
Selection.ShapeRange.Fill.Transparency = 0.5
Selection.ShapeRange.Line.Weight = 1.75
Selection.ShapeRange.Line.DashStyle = msoLineSolid
Selection.ShapeRange.Line.Style = msoLineSingle
Selection.ShapeRange.Line.Transparency = 0#
Selection.ShapeRange.Line.Visible = msoTrue
Selection.ShapeRange.Line.ForeColor.SchemeColor = 64
Selection.ShapeRange.Line.BackColor.RGB = RGB(255, 255, 255)

End If
End Sub

 

[Dthmtlgod]

Bob,

You can probably setup a loop.
Do you run your macro manually?

Something like (not tested).

dim x as range
x = 1 (or whatever)

do while range("R" & x) = "insert a stopping point"
if range("R" & x) = 1
** Turn Rectangle On code **
else
** Turn Rectangle Off code **
x = x + 1
loop

 

[Bob]

I have the macro assigned to a Form Control Button, so yes, I run it
manually.

Your advice helps a little but my major problem is each rectangle has
its own name (i.e., "Rectangle 136", "Rectangle 137"...."Rectangle
185")

I have a transparent rectangle that "hovers" over a cell. When the
cell value is 1, I make the rectangle visable. When the cell is 0 I
make the cell transparent. Again, I have 50 different rectangles
"hovering" over 50 different cells. With my code, I would have to
repeat the if statement 50 times. I figure there has to be an easier
way.

Thanks again.

 

[Dave Peterson]

If you give your rectangles nice names (include the address of the cell that
controls them in the name), then you could use one piece of code that does the
work (well, maybe):

I assumed your range was R8:R57. Then I could run this to add rectangles with
nice names (in a General module and only run once):

Option Explicit
Sub runThisOneTimeOnly()

Dim myRect As Rectangle
Dim myCell As Range
Dim RangeWithRects As Range
Dim wks As Worksheet
Dim iCtr As Long
Dim myShape As Shape

Set wks = ActiveSheet

With wks
'range to get rectangles
Set RangeWithRects = .Range("r8:r57")

'delete existing rectangles
For Each myShape In .Shapes
If myShape.Type = msoAutoShape Then
If myShape.AutoShapeType = msoShapeRectangle Then
myShape.Delete
End If
End If
Next myShape

For Each myCell In RangeWithRects.Cells
With myCell
Set myRect = .Parent.Rectangles.Add _
(Top:=.Top, _
Left:=.Left, _
Height:=.Height, _
Width:=.Width)
myRect.Name = "Rect_" & .Address(0, 0)
End With
With myRect
With .ShapeRange.Fill
.Visible = msoFalse
.Transparency = 0.5
End With
With .ShapeRange.Line
.Weight = 1.75
.DashStyle = msoLineSolid
.Style = msoLineSingle
.Transparency = 0#
.Visible = msoTrue 'msofalse 'to hide when starting
.ForeColor.SchemeColor = 64
.BackColor.RGB = RGB(255, 255, 255)
End With
End With
Next myCell
End With

End Sub

Then behind the worksheet that has the rectangles:

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)

Dim myRect As Rectangle

If Target.Cells.Count > 1 Then Exit Sub

Set myRect = Nothing
On Error Resume Next
Set myRect = Me.Rectangles("Rect_" & Target.Address(0, 0))
On Error GoTo 0

If myRect Is Nothing Then Exit Sub

If Target.Value = 0 Then
myRect.Visible = False
Else
myRect.Visible = True
End If

End Sub

This'll look for a manually changed cell. If it finds a corresponding rectangle
(matches on name/address), then it either hides or shows that rectangle.

==========
Another option that might work even easier is:
Format|conditional formatting.
cell value is equal 1
give it a nice border
(not quite as many options, but lots easier!)