AutoShape Copy and Paste

[Phil H]

Using Excel 2003, this code was provided to me.

On sheet 3, an oval autoshape (one of many on the worksheet) has the below
code (macro) assigned to it.

Sub PasteRedSteady()
Dim shpTemp As Shape
Set shpTemp =
ActiveWorkbook.Worksheets("Graphics").Shapes("RedSteadyPaste")
PasteCenterOfRange shpTemp
Set shpTemp = Nothing
End Sub

The pasted oval autoshape is held in a worksheet named Graphics. The
example autoshape name is RedSteadyPaste. There are others with other names
too – each different autoshape having its own paste macro. Macros are
located in Module2.

When a user selects a cell or merged cell range, and clicks on an oval
autoshape(located on that same worksheet) with the macro assigned to it, a
duplicate oval autoshape, without code assigned to it, is pasted into the
center of the selected cell/cell range.

Sub PasteCenterOfRange(UseShape As Shape)
UseShape.Copy
ActiveSheet.Paste
With ActiveSheet.Shapes(ActiveSheet.Shapes.Count)
.Left = ActiveCell.MergeArea.Left + ((ActiveCell.MergeArea.Width -
..Width) / 2)
.Top = ActiveCell.MergeArea.Top + ((ActiveCell.MergeArea.Height -
..Height) / 2)
End With
ActiveCell.Select
End Sub

1.) To delete the pasted autoshape, it is highlighted and deleted. The
problem is deletion. If the user selects a cell with an autoshape already in
it and does not delete the existing autoshape, a new autoshape can be pasted
over it, thus, many autoshapes can be “stacked†in a cell. Is there a way to
delete the current autoshape(s), or clear the cell of any graphics, before
pasting a new one? This problem is graphics are bloating file size.

2.) Another question too. Is there a way to have all these above actions
duplicated in a linked cell/range on another worksheet? Whatever happens in
the Sheet3 cell/range happens exactly the same way in a Sheet1 cell/range.
Sheet3 is the source, Sheet1 is the target.

Any help would be greatly appreciated. Thanks, Phil.

 

[Tom Ogilvy]

Sub PasteRedSteady()
Dim shpTemp As Shape
Set shpTemp =
ActiveWorkbook.Worksheets("Graphics").Shapes("RedSteadyPaste")
for each shp in Activesheet.Shapes
set rng = Range(shp.topLeftCell,shp.bottomRightCell)
if not intersect(rng,activecell) is nothing then
shp.Delete
end if
Next
PasteCenterOfRange shpTemp
Set shpTemp = Nothing
End Sub

Just have your code repeat any actions on the second sheet.

 

[Phil H]

Hi Tom,

This works exactly as needed on Sheet3. I cleared two "variable not
defined" errors by adding dim statements for shp and rng.

Sub PasteRedSteady()
Dim shpTemp As Shape
Dim shp As Shape
Dim rng As Range
Set shpTemp = ActiveWorkbook.Worksheets("Graphics").Shapes("RedSteadyPaste")
For Each shp In ActiveSheet.Shapes
Set rng = Range(shp.TopLeftCell, shp.BottomRightCell)
If Not Intersect(rng, ActiveCell) Is Nothing Then
shp.Delete
End If
Next
PasteCenterOfRange shpTemp
Set shpTemp = Nothing
End Sub

As follow-on, I'm trying to grasp code statements better. I didn't
understand the comment about having the code "repeat" on Sheet1. How would
this be done? When the code operates, it operates on the active worksheet,
whatever it is - correct? How would it work simultaneously on a linked cell
in an inactive worksheet?

I have these paste-graphics macros located in Module2 because when I finish
this model, there will be about 10 worksheets that need to operate like we
are setting up Sheet3 in this example. All the "Sheet3s" will have cells
linked to Sheet1, and Sheet1 will hold the link formula. In other words as
the ten Sheet3s are updated, that update rolls up to Sheet1 (which will be
named: "Financial Dashboard")

 

[Tom Ogilvy]

It wouldn't operate on both sheets simultaneously. You would do one sheet,
then activate the next sheet and do it with the same code.

If you don't want to see it,

Application.ScreenUpdating = False

' code that activates and operates on another sheet

Application.ScreenUpdating = True


or you could write the macro to work on another sheet by qualifying your
references. If your pasting to the activecell, however, that won't work.

 

[Phil H]

Tom, can we skin this cat another way - insert an "Update" button control on
Sheet1 with code saying: delete the graphics in cells A11, B22, C33, whatever
cell, etc; and paste the graphics in Sheet3/cellP3 to Sheet1/cellT6,
Sheet3/cellg19 to Sheet1/cell U5, etc.?

Another question - file size is growing alarmingly! I read that making each
graphic a metafile mitigates against this growth. I converted one of the
graphics to a metafile, and set it up to paste. The paste worked, but it did
not delete the previous graphic. Can we work these two issues through?