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

LVL 1
John CarneyReliability Business Tools Analyst IIAsked:
Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

kgerbChief EngineerCommented:
Hello John,
This is worth a shot.  It may be that the actual deletion of the object is taking the time.  Try adding the names of the shapes to an array and then deleting them all at once.  Not for certain it will help but it might.

Kyle
Sub deleteShapes()
Dim shp As Shape, Count As Long
Dim arr() As String
Count = 0
For Each shp In ActiveSheet.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
ActiveSheet.Shapes.Range(arr).Delete
End Sub

Open in new window

0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
hippohoodCommented:
it will work quicker if instead of deleting tem one by one you do the following:
- move the shapes to an unsued range (say, column AZ), instead of deleting them
- then delete the column AZ altogehter

Something like code below
Sub deleteShapes()
dim theLeft as long
theLeft = Columns("AZ:AZ").Left
Dim shp As Shape
    For Each shp In ActiveSheet.Shapes
            If Not Intersect(shp.TopLeftCell, Range("B2:R100")) Is Nothing Then
                    shp.Left=theLeft
            End If
    Next
    
Columns("AZ:AZ").Delete Shift:=xlToLeft

End Sub

Open in new window

0
John CarneyReliability Business Tools Analyst IIAuthor Commented:
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
0
John CarneyReliability Business Tools Analyst IIAuthor Commented:
Thanks again.

- John
0
kgerbChief EngineerCommented:
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

0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Excel

From novice to tech pro — start learning today.

Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.