Select all visible sheets except 3, then copy and paste an image

[Jason8598]

I have a workbook that when first opened, shows only a "Start" sheet. In this sheet, I input some information and then execute code that unhides the appropriate sheets and hides the appropriate rows and columns within the unhidden sheets. I then insert an image into my "Start" sheet. I need help with code that will copy/paste the image into cell "B6" in all of the sheets except the "Start" sheet and 2 summary sheets at the end, named "Summary1" and "Summary2".

 

[Domenic]

The following macro copies the last image inserted on sheet "Start", and pastes it at B6 on every worksheet within the active workbook, except sheets "Start", "Summary1", and "Summary2". Notice that it tests to make sure that the last object inserted is indeed a picture. Otherwise, an OleObject object/ActiveX control would be considered a picture and the macro would fail.

[font=Verdana][color=darkblue]Option[/color] [color=darkblue]Explicit[/color]

[color=darkblue]Sub[/color] CopyImage()

    [color=darkblue]Dim[/color] wksStart [color=darkblue]As[/color] Worksheet
    [color=darkblue]Dim[/color] wks [color=darkblue]As[/color] Worksheet
    [color=darkblue]Dim[/color] Pic [color=darkblue]As[/color] Picture
    [color=darkblue]Dim[/color] NumPics [color=darkblue]As[/color] [color=darkblue]Long[/color]
    
    [color=darkblue]Set[/color] wksStart = Worksheets("Start")
    
    NumPics = wksStart.Pictures.Count
    
    [color=darkblue]If[/color] NumPics > 0 [color=darkblue]Then[/color]
    
        [color=darkblue]If[/color] TypeName(wksStart.Pictures(NumPics)) = "Picture" [color=darkblue]Then[/color]
    
            Application.ScreenUpdating = [color=darkblue]False[/color]
    
            [color=darkblue]Set[/color] Pic = wksStart.Pictures(NumPics)
            
            [color=darkblue]For[/color] [color=darkblue]Each[/color] wks [color=darkblue]In[/color] Worksheets
                [color=darkblue]Select[/color] [color=darkblue]Case[/color] wks.Name
                    [color=darkblue]Case[/color] "Start", "Summary1", "Summary2"
                        [color=green]'Do nothing[/color]
                    [color=darkblue]Case[/color] [color=darkblue]Else[/color]
                        Pic.Copy
                        wks.Range("B6").PasteSpecial
                [color=darkblue]End[/color] [color=darkblue]Select[/color]
            [color=darkblue]Next[/color] wks
            
            Application.ScreenUpdating = [color=darkblue]True[/color]
            
            MsgBox "Completed...", vbInformation
            
            [color=darkblue]Exit[/color] [color=darkblue]Sub[/color]
            
        [color=darkblue]End[/color] [color=darkblue]If[/color]
        
    [color=darkblue]End[/color] [color=darkblue]If[/color]
    
    MsgBox "No image was found on worksheet ""Start""...", vbExclamation
                [/font]

 

[Jason8598]

Is there a way to paste the image to only the visible sheets and not the hidden sheets?

 

[Domenic]

Try replacing...

[FONT=Verdana][COLOR=darkblue]For[/COLOR] [COLOR=darkblue]Each[/COLOR] wks [COLOR=darkblue]In[/COLOR] Worksheets[/FONT]
[FONT=Verdana]  [COLOR=darkblue]Select[/COLOR] [COLOR=darkblue]Case[/COLOR] wks.Name[/FONT]
[FONT=Verdana]      [COLOR=darkblue]Case[/COLOR] "Start", "Summary1", "Summary2"[/FONT]
[FONT=Verdana]          [COLOR=green]'Do nothing[/COLOR][/FONT]
[FONT=Verdana]      [COLOR=darkblue]Case[/COLOR] [COLOR=darkblue]Else[/COLOR][/FONT]
[FONT=Verdana]          Pic.Copy[/FONT]
[FONT=Verdana]          wks.Range("B6").PasteSpecial[/FONT]
[FONT=Verdana]  [COLOR=darkblue]End[/COLOR] [COLOR=darkblue]Select[/COLOR][/FONT]
[FONT=Verdana][COLOR=darkblue]Next[/COLOR] wks[/FONT]

with

[FONT=Verdana][COLOR=darkblue]For[/COLOR] [COLOR=darkblue]Each[/COLOR] wks [COLOR=darkblue]In[/COLOR] Worksheets[/FONT]
[FONT=Verdana]  [COLOR=darkblue]If[/COLOR] wks.Visible = [COLOR=darkblue]True[/COLOR] [COLOR=darkblue]Then[/COLOR][/FONT]
[FONT=Verdana]      [COLOR=darkblue]Select[/COLOR] [COLOR=darkblue]Case[/COLOR] wks.Name[/FONT]
[FONT=Verdana]          [COLOR=darkblue]Case[/COLOR] "Start", "Summary1", "Summary2"[/FONT]
[FONT=Verdana]              [COLOR=green]'Do nothing[/COLOR][/FONT]
[FONT=Verdana]          [COLOR=darkblue]Case[/COLOR] [COLOR=darkblue]Else[/COLOR][/FONT]
[FONT=Verdana]              Pic.Copy[/FONT]
[FONT=Verdana]              wks.Range("B6").PasteSpecial[/FONT]
[FONT=Verdana]      [COLOR=darkblue]End[/COLOR] [COLOR=darkblue]Select[/COLOR][/FONT]
[FONT=Verdana]  [COLOR=darkblue]End[/COLOR] [COLOR=darkblue]If[/COLOR][/FONT]
[FONT=Verdana][COLOR=darkblue]Next[/COLOR] wks[/FONT]

 

[Jason8598]

Awesome... Now I would like the image to move to the right 3 increments and then down 3 increments so that the image is not right on the corner of the cell. I tried adding
Selection.ShapeRange.IncrementLeft 3
Selection.ShapeRange.IncrementTop 3
but I get an error "Object doesn't support this property or method"

Hopefully this is the last thing I need.

 

[Domenic]

Try...

[font=Verdana][color=darkblue]For[/color] [color=darkblue]Each[/color] wks [color=darkblue]In[/color] Worksheets
    [color=darkblue]If[/color] wks.Visible = [color=darkblue]True[/color] [color=darkblue]Then[/color]
        [color=darkblue]Select[/color] [color=darkblue]Case[/color] wks.Name
            [color=darkblue]Case[/color] "Start", "Summary1", "Summary2"
                [color=green]'Do nothing[/color]
            [color=darkblue]Case[/color] [color=darkblue]Else[/color]
                Pic.Copy
                wks.Range("B6").PasteSpecial
                [color=darkblue]With[/color] wks.Pictures(wks.Pictures.Count)
                    [color=darkblue]With[/color] .ShapeRange
                        .IncrementLeft 3
                        .IncrementTop 3
                    [color=darkblue]End[/color] [color=darkblue]With[/color]
                [color=darkblue]End[/color] [color=darkblue]With[/color]
        [color=darkblue]End[/color] [color=darkblue]Select[/color]
    [color=darkblue]End[/color] [color=darkblue]If[/color]
[color=darkblue]Next[/color] wks
[/font]

 

[Jason8598]

Thank you for the help.

 

[Domenic]

You're very welcome!