Copy current worksheet to another workbook without shape buttons but copy image

[jb]

I have written below code to copy current worksheet to another workbook at desired location. This VBA code works perfectly.
My current worksheet has 2 buttons and one image.
I have used Application.CopyObjectsWithCells = False and Application.CopyObjectsWithCells = True for not copying objects in new workbook.
that works fine. But it removes 2 buttons alongwith image in new workbook.
But I want to copy image not the buttons.
I have tried a loop which is given in comments in below code. This loop is not working that's why commented.
Suggest changes please.

>>> How many times have to give same note? <<<
>>> use code - tags <<<​

Sub save_consolidated()

   Dim NewWb As Workbook
   Dim ws As Worksheet
   Dim fname As Variant
   Dim wbname As String
   Dim s As Shape

   wbname = "Consolidated Activity Leave " + ActiveWorkbook.Sheets("Consolidated").Range("N1")
   fname = Application.GetSaveAsFilename(InitialFileName:=wbname, filefilter:=" Excel Macro Free Workbook (*.xlsx), *.xlsx,")
     
   
   Application.CopyObjectsWithCells = False
   'copy your sheet
   ActiveSheet.Copy
   Application.CopyObjectsWithCells = True 'reset
  
   Set NewWb = ActiveWorkbook
  
   NewWb.SaveAs fname, FileFormat:=51, CreateBackup:=False
  
   'For Each s In ActiveSheet.Shapes
   'MsgBox s.Name
    'Select Case s.Name
        'Case "Picture 1"
            ' do nothing
        'Case Else
                's.Delete
        'End Select
   'Next s
  
   NewWb.Close False
 
   Set NewWb = Nothing
  
End Sub

 

[p45cal]

Just glancing at the code and not trying it, I'd try leaving
Application.CopyObjectsWithCells = True
so that you do copy objects. Then you'll have something to delete in the loop!.
Also, your SaveAs should probably come after you've done the deleting.

 

[jb]

>>> How many times have to give same note? <<<
>>> use code - tags <<<​

Application.CopyObjectsWithCells = False
'copy your sheet
ActiveSheet.Copy
Application.CopyObjectsWithCells = True 'reset

With this lines of code, my 2 shape button and one picture image will not be copied in new workbook.
But I want picture to be copied in new workbook.

So, I tried the loop. In this situation, I added comment Application.CopyObjectsWithCells = False and Application.CopyObjectsWithCells = True 'reset lines. So, I got picture and shape button everything in my new workbook. I have used below code.

'For Each s In ActiveSheet.Shapes
'MsgBox s.Name
'Select Case s.Name
'Case "Picture 1"
' do nothing
'Case Else
's.Delete
'End Select
'Next s

Using this loop, I tried to keep picture as it is in new workbook and trying to delete all other objects which is in my case shape buttons.

But this logic is not working . It is not removing shape buttons.

So, I stucked up.

 

[p45cal]

With this lines of code, my 2 shape button and one picture image will not be copied in new workbook.
But I want picture to be copied in new workbook.

So, don't tamper with Application.CopyObjectsWithCells, leave it as the default TRUE.
As I said:

Sub save_consolidated()
Dim NewWb As Workbook
Dim ws As Worksheet
Dim fname As Variant
Dim wbname As String
Dim s As Shape

wbname = "Consolidated Activity Leave " + ActiveWorkbook.Sheets("Consolidated").Range("N1")
fname = Application.GetSaveAsFilename(InitialFileName:=wbname, filefilter:=" Excel Macro Free Workbook (*.xlsx), *.xlsx,")
  
ActiveSheet.Copy
Set NewWb = ActiveWorkbook
For Each s In ActiveSheet.Shapes
  'MsgBox s.Name
  Select Case s.Name
  Case "Picture 1"
    'do nothing
  Case Else
    s.Delete
  End Select
Next s
NewWb.SaveAs fname, FileFormat:=51, CreateBackup:=False
NewWb.Close False
Set NewWb = Nothing
End Sub

Also, your SaveAs should probably come after you've done the deleting.

This adjustment has also been made in the above code.
I tried this and it seems to work.

 

[jb]

So, don't tamper with Application.CopyObjectsWithCells, leave it as the default TRUE.
As I said:

Sub save_consolidated()
Dim NewWb As Workbook
Dim ws As Worksheet
Dim fname As Variant
Dim wbname As String
Dim s As Shape

wbname = "Consolidated Activity Leave " + ActiveWorkbook.Sheets("Consolidated").Range("N1")
fname = Application.GetSaveAsFilename(InitialFileName:=wbname, filefilter:=" Excel Macro Free Workbook (*.xlsx), *.xlsx,")
 
ActiveSheet.Copy
Set NewWb = ActiveWorkbook
For Each s In ActiveSheet.Shapes
  'MsgBox s.Name
  Select Case s.Name
  Case "Picture 1"
    'do nothing
  Case Else
    s.Delete
  End Select
Next s
NewWb.SaveAs fname, FileFormat:=51, CreateBackup:=False
NewWb.Close False
Set NewWb = Nothing
End Sub

This adjustment has also been made in the above code.
I tried this and it seems to work.

Thank you so much helper. It worked perfectly. Thanks again.