Copy Multiple Pictures from 1 Sheet and Paste to Multiple Others In Same Location

[Pepperdine21]

I am trying to copy 3 pictures from a sheet titled "Hidden" and paste them in cell B2 of each sheet using a for loop.

Here is my current code. I get no error messages but nothing pastes in any of the desired sheets.

dim Sht as Worksheet

For Each Sht In Worksheets
If Not Sht.Name = "Intro" Then
Worksheets("Hidden").Select
ActiveSheet.Shapes.Range(Array("Picture 8", "Picture 7", "Picture 9")).Select
Selection.Copy

Sht.Activate
Sht.Select
Sht.Range("B1").PasteSpecial

End If
Next


-TIA

 

[Domenic]

You can first group those shapes, then copy them to each of the target worksheets, and then ungroup them. The following macro assumes that the workbook containing the relevant worksheets is the active workbook. If, however, the workbook containing the relevant worksheets is the workbook running the code, you should qualify your worksheet references . . .

Set GrpShp = ThisWorkbook.Worksheets("Hidden").Shapes.Range(Array("Picture 8", "Picture 7", "Picture 9")).Group

Here's the code . . .

Option Explicit

Sub test()

    Dim Sht As Worksheet
    Dim GrpShp As Shape
 
    Set GrpShp = Worksheets("Hidden").Shapes.Range(Array("Picture 8", "Picture 7", "Picture 9")).Group
 
    GrpShp.Copy
 
    For Each Sht In Worksheets
        If Sht.Name <> "Intro" And Sht.Name <> "Hidden" Then
            Sht.Paste Sht.Range("B1")
            With Sht
                .Shapes(.Shapes.Count).Ungroup
            End With
        End If
    Next
 
    GrpShp.Ungroup

End Sub

By the way, for efficiency, you should set ScreenUpdating to False at the beginning of the code, and then back to True and the end of it...

Option Explicit

Sub test()

    Dim Sht As Worksheet
    Dim GrpShp As Shape
 
    Application.ScreenUpdating = False
 
    Set GrpShp = Worksheets("Hidden").Shapes.Range(Array("Picture 8", "Picture 7", "Picture 9")).Group
 
    GrpShp.Copy
 
    For Each Sht In Worksheets
        If Sht.Name <> "Intro" And Sht.Name <> "Hidden" Then
            Sht.Paste Sht.Range("B1")
            With Sht
                .Shapes(.Shapes.Count).Ungroup
            End With
        End If
    Next
 
    GrpShp.Ungroup
 
    Application.ScreenUpdating = True

End Sub

Hope this helps!