Copy selected graphic to other worksheets using VBA

Dear Experts:

I would like to copy the currently selected graphic (named 'My_Graphic') to all other worksheets (except a worksheet named Base_Sheet) of the active workbook  using VBA

The graphic is to be positioned on the respective worksheets at the following position:

From Left: 3 cm
From Top: 4,2 cm.

After copying and positioning the graphics are to be ungrouped.

Help is much appreciated. Thank you very much in advanced.

Regards, Andreas
Andreas HermleTeam leaderAsked:
Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

Fernando Bravo DiazCommented:
You can get the shapes in a worksheet with this:

Dim sp As Shape
Worksheet1.Shapes("Imagen 2").Copy

Open in new window

then to copy it to the next worksheets:

For Each ws In Worksheets
        If <> "Base_Sheet" Then
            'Your sheet range to paste the shape
            Worksheet1.Paste ws.Range("A1")
        End If
Next ws

Open in new window

Subodh Tiwari (Neeraj)Excel & VBA ExpertCommented:
Hi Andreas,

Please give this a try...

Sub CopyGraphic()
Dim Shp As Shape, eShp As Shape
Dim ws As Worksheet

On Error Resume Next
If Not TypeName(Selection) = "Range" Then
    Set Shp = Selection.ShapeRange.Item(1)
    If Shp.Name = "My_Graphic" Then
        For Each ws In Worksheets
            If ws.Name <> "Base_Sheet" Then
                Set eShp = ws.Shapes("My_Graphic")
                If eShp Is Nothing Then
                    With ws.Shapes("My_Graphic")
                        .Left = 3 * 28.34646
                        .Top = 4.2 * 28.34646
                    End With
                End If
            End If
            Set eShp = Nothing
        Next ws
    End If
    MsgBox "No Shape was selected to copy.", vbExclamation
End If
End Sub

Open in new window

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
I was able to do this with INDIRECT and using named ranges to refer to the graphics, an example workbook is in this question:

It works great but can bog down a larger workbook, which is why I am looking for an alternative.
Big Business Goals? Which KPIs Will Help You

The most successful MSPs rely on metrics – known as key performance indicators (KPIs) – for making informed decisions that help their businesses thrive, rather than just survive. This eBook provides an overview of the most important KPIs used by top MSPs.

Andreas HermleTeam leaderAuthor Commented:
Dear all,

thank you very much for your great and swift support.

As a matter of fact Neeraj's code is exactly what I was looking for and everything works like a charm with Neeraj's code.

Thank you
Andreas HermleTeam leaderAuthor Commented:
What is the matter with this website. I cannot close the question, there are not buttons to do so. Strange :-(
Andreas HermleTeam leaderAuthor Commented:
I am still not able to award points ... no buttons exist to do so. Must be some strange malfunctioning of the website.
Andreas HermleTeam leaderAuthor Commented:
nice job, thank you very much for it
Subodh Tiwari (Neeraj)Excel & VBA ExpertCommented:
You're welcome Andreas! Glad it worked as desired.
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today

From novice to tech pro — start learning today.