asked on

Macro that will delete only the shapes in a specified range

For some reason, perhaps because my network is so slow, I find that the standard macro for this takes up a lot of time. (See code below) Just wondering if there is anything new in this area. I just can't seem to give up on the idea that there is a VBA code that selects/deletes all the shapes in Range("B2:R100") and only those shapes :-)

Thanks,
John

Sub deleteShapes()
Dim shp As Shape
    For Each shp In ActiveSheet.Shapes
            If Not Intersect(shp.TopLeftCell, Range("B2:R100")) Is Nothing Then
                    shp.Delete
            End If
    Next
End Sub

Open in new window

ASKER CERTIFIED SOLUTION

kgerb

membership

This solution is only available to members.

To access this solution, you must be a member of Experts Exchange.

Start Free Trial

SOLUTION

hippohood

membership

This solution is only available to members.

To access this solution, you must be a member of Experts Exchange.

Start Free Trial

John Carney

ASKER

Hi kqerb, I got an error on the last line but thanks for posting. Hippohood, I can see some definite = value in your code but in my experience when I delete columns or rows, the shapes in them don'e get deleted.

I guess there's still no way to directly select only the shapes in a specified arrange. Oh well, thanks for your suggestions. :-)

Thanks,
John

John Carney

ASKER

Thanks again.

- John

kgerb

John, after 2000 questions you should know the drill. Please give us the opportunity to "earn" an A grade before closing the question with a lower grade.

What exactly was wrong with the code? You got an error on line 12? Was the sheet which you are deleting all the shapes on active when you ran the code?

Try the following, I changed Activesheet to a specific sheet. Replace "Sheet1" with the name of your sheet.

Kyle

Sub deleteShapes()
Dim shp As Shape, Count As Long
Dim arr() As String
Dim sSheet As String

Count = 0
sSheet = "Sheet1"

For Each shp In Sheets(sSheet).Shapes
    If Not Intersect(shp.TopLeftCell, Range("B2:R100")) Is Nothing Then
        ReDim Preserve arr(Count + 1)
        arr(Count) = shp.Name
        Count = Count + 1
    End If
Next
Sheets(sSheet).Shapes.Range(arr).Delete
End Sub

Open in new window