Macro to Fit AutoShape over Range?

[Wart]

It seems to me that inserting and manipulating AutoShapes is incredibly
straightforward in Excel, but users of a form in our office have asked if
there's a way to more quickly make rectangles that would EXACTLY cover
whatever range of cells they have selected. (This is all the more annoying of
a request, because most of the users are on Excel for Mac, whose Formatting
Palette makes this sort of thing even easier.)

Anyway: can a macro be written that will do this? I'm imagining that, after
a user left-clicks and drags through any area, that they'll right-click,
select the macro from the shortcut menu, and the code will plop a rectangle
over the area. (I already have a number of custom options on the shortcut
menu, so that I can do that part myself.)

I know this is all absurd, but any help anyone can offer would be much
appreciated!

 

[Bob Umlas, Excel MVP]

This macro creates an exact ractangle and if you click it, it goes away.
Sub rect()
On Error Resume Next
Set Startingcell = Application.InputBox("Enter address of starting cell
for the rectangle", _
default:=ActiveCell.Address, Type:=8)

If Startingcell.Address = "" Then Exit Sub
Set Endingcell = Application.InputBox("Enter address of ending cell for
the rectangle", Type:=8)
If Endingcell.Address = "" Then Exit Sub
'format is left, top, width, height
If Startingcell.Column > 1 Then
leftamt = Range("a1", Startingcell.Offset(, -1)).Width
Else: leftamt = 0
End If
If Startingcell.Row > 1 Then
topamt = Range("a1", Startingcell.Offset(-1)).Height
Else: topamt = 0
End If
Widthamt = Range(Startingcell.Address, Endingcell.Address).Width
Heightamt = Range(Startingcell.Address, Endingcell.Address).Height
ActiveSheet.Rectangles.Add leftamt, topamt, Widthamt, Heightamt
ActiveSheet.Rectangles(ActiveSheet.Rectangles.Count).OnAction = "Deleteme"
End Sub
Sub Deleteme()
ActiveSheet.Rectangles(Application.Caller).Delete
End Sub

 

[Bob Phillips]

Sub CreateAutoShape()

With ActiveSheet.Shapes

.AddShape(msoShapeRectangle, _
Selection.Left, Selection.Top, Selection.Width,
Selection.Height).Select
End With

With Selection.ShapeRange
.Fill.Visible = msoTrue
.Fill.Solid
.Fill.ForeColor.SchemeColor = 65
.Fill.Transparency = 0.67
.Line.Weight = 0.75
.Line.DashStyle = msoLineSquareDot
.Line.ForeColor.SchemeColor = 51
.Line.BackColor.RGB = RGB(255, 255, 255)
.Fill.Visible = msoTrue
.Fill.Solid
.Fill.ForeColor.SchemeColor = 47
.Fill.Transparency = 0.74
End With
End Sub


--
HTH

Bob

(there's no email, no snail mail, but somewhere should be gmail in my addy)

 

[Gary''s Student]

Select a block of cells and run:

Sub Macro1()
Set r = Selection
ActiveSheet.Shapes.AddShape(msoShapeRectangle, 46.5, 12#, 193.5, 53.25).Select

Selection.Top = r.Top
Selection.Left = r.Left
Selection.Height = r.Height
Selection.Width = r.Width
End Sub

 

[Gord Dibben]

You want a filled rectangle?

Sub Yellow_Rectangle()
Dim X, y As Single, area As Range
For Each area In Selection.Areas
With area
X = .Height * 0#
y = .Width * 0#
ActiveSheet.Rectangles.Add Top:=.Top - X, Left:=.Left - y, _
Height:=.Height + 1 * X, Width:=.Width + 1 * y
End With
With ActiveSheet.Rectangles(ActiveSheet.Rectangles.Count)
.Interior.ColorIndex = 2
.ShapeRange.AutoShapeType = msoShapeRectangle
End With
Next area
End Sub

Note: will work on multiple select ranges


Gord Dibben MS Excel MVP

 

[Wart]

Thanks, Bob, for the fast and helpful response! Both yours and Gary"s
Student's response, below, work great! EXCELLENT!

 

[Wart]

Hey, there--
See my reply to Bob, above--Both this and the other macros (I see Bob pilips
just replied, too!) are great! Probably my coworkers will just spend the rest
of the day making rectangles, now.

Thank you all so much!

 

[Wart]

See my messages to the others, above. Now I have THREE different macros to
play with--perhaps I'll ask my coworkers to vote. Truly, all of you have
made this day better than it was--thanks!