deleting shapes with VBA code



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")
Set sr = Selection.ShapeRange

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.


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



(change the xxxx to gmail if mailing direct)

Dave Peterson

Ron de Bruin has lots of sample code here:

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( = lcase("keepthisone") then
'do nothing
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<>"yourname" then sh. cut
end sub

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question