PDA

View Full Version : [SOLVED] Copy Paste Shapes to Different Worksheets Loop



dj44
06-26-2016, 05:37 AM
Hi folks,

I have a list of shapes i need to copy and paste to different worksheets,
I just cant seem to get it right.:(

In Column A I have put the worksheet name
Column B Shape Name

Example

Worksheet ---- Shape Name
Jan ------- ShapeX
Feb--------- ShapeY


I would like to copy the shapes to the correct worksheet. these are basic shapes like rectangles



Sub CopyPasteShape()

Dim wsh As Worksheet
Dim oDest As Worksheet

Dim i As Integer
Dim oShape As Shape

oDest = wsh.Cells(i, "A").Value2

Set wsh = Worksheets("Shapes")
For i = 3 To wsh.Cells(wsh.Rows.Count, "A").End(xlUp).Row


Set oShape = wsh.Shapes(wsh.Cells(i, "B").Value2).Copy

oShape = wsh.Shapes(wsh.Cells(i, "B").Value2).Copy
wsh.Cells(i, "A").Value2.Paste


Next i

End Sub


I dont know how to make the syntax correct,

thanks for helping

dj

Kenneth Hobs
06-26-2016, 10:39 AM
Sub CopyPasteShapes()
Dim wsh As Worksheet, oDest As Worksheet
Dim i As Long, oShape As Shape, oShape2 As Shape

'On Error Resume Next
Set wsh = Worksheets("Shapes")

For i = 3 To wsh.Cells(wsh.Rows.Count, "A").End(xlUp).Row
Set oDest = Worksheets(wsh.Cells(i, "A").Value2)
Set oShape = wsh.Shapes(wsh.Cells(i, "B").Value2)
oShape.Copy
oDest.Paste
Application.CutCopyMode = False
Set oShape2 = oDest.Shapes(oDest.Shapes.Count)
With oDest.Range("A" & i)
oShape2.Top = .Top
oShape2.Left = .Left
oDest.Activate
.Select
wsh.Select
End With
Next i
End Sub

dj44
06-26-2016, 12:32 PM
Thank you very much Kenneth,

this worked a treat!

Really appreciate the help :)

dj