Macro to Fit AutoShape over Range?
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.Coun t).OnAction = "Deleteme"
End Sub
Sub Deleteme()
ActiveSheet.Rectangles(Application.Caller).Delete
End Sub
"Wart" wrote:
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!
|