deleting shapes with VBA code

[Rick_T]

I have a worksheet that containes a number of shapes (pictures). The number
could range from 1 to 30. I want to deleate all the shapes at one time
EXCEPT for one particular shape.
With the code below I can select all the shapes in the worksheet and delete
them. The problem is it also deletes the one shape I want to retain.

Set myDocument = Worksheets("Form-99")
myDocument.Shapes.SelectAll
Set sr = Selection.ShapeRange
Selection.Cut

I tried setting a range of column Q; all the shapes I want to delete are in
the Q column but there is also data in the column I don't want to delete, I
only want to remove the shapes. The problem is that this method only deletes
one shape for each time it runs, it doesn't delete all the shapes with one
run cycle. I tried deleteAll with the range code but it didn't work. Thanks
for any help you can offer.

Sheets("Form-99").Select
ActiveSheet.Shapes("Signature").Select
ActiveSheet.Shapes.Range(Array("Q8:Q74")).Select
Selection.Cut

 

[Bob Phillips]

'----------------------------------------------------------------
Sub RemoveShapes()
'----------------------------------------------------------------
' Written by : Bob Phillips
' Inspired by: Debra Dalgleish & Dave Peterson
' Improved by: Dave Peterson (cater for forms combobox)
'---------------------------------------------------------------
' Synopsis: Checks each shape to be form control, and if it
' is a dropdown, it aims to retain it.
' One problem is that the forms combobox which is
' also a form control, and is a dropdown, so it
' does not get deleted.
'
' Catered for by testing top left of shape, as
' Autofilter and Data Validation dropdowns do not
' seem to have a topleftcell address.
'---------------------------------------------------------------
Dim shp As Shape
Dim sTopLeft As String
Dim fOK As Boolean

For Each shp In Worksheets("Form-99").Shapes

fOK = True

sTopLeft = ""
On Error Resume Next
sTopLeft = shp.TopLeftCell.Address
On Error GoTo 0

If shp.Type = msoFormControl Then
If shp.FormControlType = xlDropDown Then
If sTopLeft = "" Then
fOK = False 'keep it
End If
End If
ElseIf shp.Name = "Rectangle 7" Then '<=== change to suit
fOK = False
End If

If fOK Then shp.Delete

Next shp

End Sub

--
---
HTH

Bob

(change the xxxx to gmail if mailing direct)

 

[Dave Peterson]

Ron de Bruin has lots of sample code here:
http://www.rondebruin.nl/controlsobjectsworksheet.htm

I modified one of the routines:

Sub Shapes2()
Dim myShape As Shape
For Each myshape In ActiveSheet.Shapes
If myshape.Type = msoPicture Then
if lcase(myshape.name) = lcase("keepthisone") then
'do nothing
else
myshape.Delete
end if
Next myshape
End Sub

 

[Don Guillett]

a simple form to try. Look in name box for the name of your shape

sub deleteallbutoneshape
for each sh in activesheet.shapes
if sh.name<>"yourname" then sh. cut
next
end sub