Copying shapes and paste to different worksheets using VBA

[Banyez]

Thank you for all the solutions to questions others have posted. I've been able to get pretty far in VBA without having to ask any questions, simply by reading what you all have written here. So now I have problems with what should be pretty simple...


Problem: I can't seem to find an efficient way to copy and paste shapes (line and picture)using VBA. Does anyone have a good way to simplify or make more efficient the following code?

Code: obtained from running create macro-

ActiveSheet.Shapes.Range(Array("Line 1","Picture2")).Select
Selection.Copy
Sheets("Sheet3").Select
Cells.Select
ActiveSheet.Paste

I tried to do the following but got the error
>>>object doesn't support this property or method<<<

ActiveSheet.Shapes.Range(Array(1, 2)).Copy

So clearly I've not got the syntax down.

Thanks for any suggestions
-Banyez

 

[combo]

Your #1 code is OK, check shape names. In non English excel the recorder uses English names (Rectangle x, Line y etc.), in the 'names' window they appear local.

combo

 

[Banyez]

Thank you combo for your response.

I was wondering if the first lines of code can be made more efficient. It really slows down the macro to actively select the shapes, then copy then paste.

There are ways to copy information in cells without the select, copy,paste method, and I was hoping that there was a way to do this with the shapes object.

Thanks again.

 

[combo]

You can copy shape by shape without selecting:

Worksheets("SourceSheet").Shapes(1).Copy
Worksheets(2).Paste Destination:=Range("D4")

combo

 

[Fr33dan]

You could eliminate the selecting and just use

ActiveSheet.Shapes.Range(Array("Line 1","Picture2")).Copy
Sheets("Sheet3").Cells.Paste

Also try setting Application.ScreenUpdating to false at the beginning of your code. That makes the code run alot quicker.

 

[Banyez]

combo, I've thought about using that code. I was hoping to copy all the shapes at once so then I could loop through all the worksheets (22 of them) and paste them all at once. Otherwise I need to create a loop for each shape.


Fr33dan, when I do what you suggest I get the same error I got originally:
>>> run-time error 438 - Object does not support this property or method <<<

Good tip with Application.ScreenUpdating (I use this already otherwise I'd have pulled all my hair out waiting for the macro to end )

 

[Fr33dan]

You'd have to re-update the names to the local versions of themselves like combo said in the first response. I don't know them so I just used the names that were originally there.

 

[Banyez]

Yes, Those are the local names ("Line 1", "Picture2").

 

[Fr33dan]

Well if they're the only shapes objects on the sheet then you could use a nested loop to copy each object individually on each sheet:

Sub CopyAllShapes()
    Application.ScreenUpdating = False
    Set xlShapes = Sheets(ActiveSheet.Index).Shapes
    For i = 2 To Sheets.Count
        For j = 1 To xlShapes.Count
            xlShapes(j).Copy (Sheets(i))
            Sheets(i).Paste
        Next j
    Next i
End Sub

Assuming that the shapes are on the first Sheet

 

[Banyez]

Thanks Fr33dan, I'll try this out.

 

[VRoscioli]

I'm not sure, but it might be faster to reverse the order of the loops (this cuts out most of the copy operations by handling all of the pastes for each shape in one loop).

Modification of Fr33dan's code:

Sub CopyAllShapes()
    Application.ScreenUpdating = False
    Set xlShapes = Sheets(ActiveSheet.Index).Shapes
    For j=1 to xlShapes.Count
        xlShapes(j).Copy
        For i = 2 To Sheets.Count
            Sheets(i).Paste
        Next i
    Next j
    Application.ScreenUpdating = True
End Sub

-V

 

[combo]

You can test copying after grouping (or have a permanently grouped shapes):

With ActiveSheet.Shapes.Range(Array(...))
    .Group.Copy
    ' loop destination worksheets here
    ' ungroup last shape in destination sheet if necessary
    .Ungroup
End With

combo