VBA Delete for Shapes Range Very Slow

[cliffmichael]

Hello,

I am using Excel 2013 VBA Application.Intersect method to Shape.Delete specific Shapes at specific cell locations, which is Worksheet Event based. It deletes a previously selected shape (or multiple shapes) before a new shape is copied and pasted in its place. It works, however, I have noticed that the code takes longer and longer to execute.

For example, when I step-through the code to observe its behavior, I notice that when it gets to the Application.Intersect...shp.Delete for one shape deletion—it toggles repeatedly between the shp.Delete line and Next shp line up to 75-times before moving to the next line in code. Some code lines must delete up to a dozen preexisting shapes and these take even longer to execute.

I have been building and editing hundreds of lines of code in the same file for quite a while. I'm wondering if because of a great many edits there may be hidden content that is cluttering up the code with extra stuff. Or, otherwise, am I missing an important housekeeping method.

Thank you, cliff

Here is excerpt of code

[VBA]

Sub Worksheet_Change(ByVal Target As Excel.Range)
Application.ScreenUpdating = False
Dim shp As Shape

'First iteration of Shapes selection
If Target.Address = "$C$4" Then
Select Case Target.Value
Case "FirstView"
'Delete previously pasted shape in stated range cell location.
For Each shp In Worksheets("Sheet2").Shapes
If Not Application.Intersect(shp.TopLeftCell, Worksheets("Sheet2").Range("A1,H1")) Is Nothing Then shp.Delete
Next shp
'Select shape and assign cell location
Worksheets("Sheet1").Shapes("Shape1").Copy: Worksheets("Sheet2").Paste Destination:=Worksheets("Sheet2").Range("A1")
Worksheets("Sheet1").Shapes("Shape2").Copy: Worksheets("Sheet2").Paste Destination:=Worksheets("Sheet2").Range("H1")
End Select
End If
Application.ScreenUpdating = True
End Sub


[/VBA]

[mana]

avoid loop!

On Error Resume Next
Worksheets("Sheet2").Shapes("Shape1").Delete
Worksheets("Sheet2").Shapes("Shape2").Delete
On Error GoTo 0

[Paul_Hossler]

I assume that you have to loop the shapes because more than one might overlap the cell

Try turning off Events

Sub Worksheet_Change(ByVal Target As Excel.Range) 
    Dim shp As Shape 
     

    Application.ScreenUpdating = False 
    Application.EnableEvents = False '------------------------------------


     'First iteration of Shapes selection
    If Target.Address = "$C$4" Then 
        Select Case Target.Value 
        Case "FirstView" 
             'Delete previously pasted shape in stated range cell location.
            For Each shp In Worksheets("Sheet2").Shapes 
                If Not Application.Intersect(shp.TopLeftCell, Worksheets("Sheet2").Range("A1,H1")) Is Nothing Then shp.Delete 
            Next shp 
             'Select shape and assign cell location
            Worksheets("Sheet1").Shapes("Shape1").Copy: Worksheets("Sheet2").Paste Destination:=Worksheets("Sheet2").Range("A1") 
            Worksheets("Sheet1").Shapes("Shape2").Copy: Worksheets("Sheet2").Paste Destination:=Worksheets("Sheet2").Range("H1") 
        End Select 
    End If 
    Application.EnableEvents = True ' ---------------------------------------
    Application.ScreenUpdating = True 
End Sub

[cliffmichael]

Hello Mana,

Thank you for your recommendation. I'm afraid I am not as skilled as I had hoped. I am unable to properly integrate this code into the existing code without continued loop delays. Will you please provide more guidance on where it should be placed and what should be removed.

thanks, cliff

[cliffmichael]

[QUOTE=Paul_Hossler;350653]I assume that you have to loop the shapes because more than one might overlap the cell

Try turning off Events



Hello Paul,

Yes, correct, more than one shape can reside in any given upper-left-hand-corner cell location. No Joy on turning events off.

Thanks, cliff

[Paul_Hossler]

You can 'clean' a worksheet manually, but Rob Bovey's automates the process. He has a nice writeup about the need for it

http://www.appspro.com/Utilities/CodeCleaner.htm



I don't suppose that there are 75 shapes on the sheet?

Option Explicit
Sub Worksheet_Change(ByVal Target As Excel.Range)
    Dim shp As Long
     
    If Target.Address <> "$C$4" Then Exit Sub
    If Target.Value <> "FirstView" Then Exit Sub
     
    MsgBox Me.Shapes.Count
     
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    For shp = Worksheets("Sheet2").Shapes.Count To 1 Step -1
        With Worksheets("Sheet2").Shapes(shp)
            If Not Application.Intersect(.TopLeftCell, Worksheets("Sheet2").Range("A1,H1")) Is Nothing Then .Delete
        End With
    Next shp
            
'   Worksheets("Sheet1").Shapes("Shape1").Copy: Worksheets("Sheet2").Paste Destination:=Worksheets("Sheet2").Range("A1")
'   Worksheets("Sheet1").Shapes("Shape2").Copy: Worksheets("Sheet2").Paste Destination:=Worksheets("Sheet2").Range("H1")
    
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

[Paul_Hossler]

This might be a little faster since it doesn't use Intersect

Option Explicit
Sub Worksheet_Change(ByVal Target As Excel.Range)
    Dim shp As Long
     
    If Target.Address <> "$C$4" Then Exit Sub
    If Target.Value <> "FirstView" Then Exit Sub
     
    MsgBox Me.Shapes.Count
     
    Application.ScreenUpdating = False
    Application.EnableEvents = False
     
    For shp = Worksheets("Sheet2").Shapes.Count To 1 Step -1
        With Worksheets("Sheet2").Shapes(shp)
            Select Case .TopLeftCell.Address
                Case "$A$1", "$H$1"
                    .Delete
            End Select
        End With
    Next shp
     
     '   Worksheets("Sheet1").Shapes("Shape1").Copy: Worksheets("Sheet2").Paste Destination:=Worksheets("Sheet2").Range("A1")
     '   Worksheets("Sheet1").Shapes("Shape2").Copy: Worksheets("Sheet2").Paste Destination:=Worksheets("Sheet2").Range("H1")
     
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

[cliffmichael]

Hi, as a matter of fact there are about that many total shapes on the worksheet. However, there are much fewer of interest called out at any given specific cell location. Interesting, I didn't make that connection.

[Paul_Hossler]

That's the way For Each works

For Each shp In Worksheets("Sheet2").Shapes

However, it still should not take long to go through 70+ shapes, and delete some

However2 -- usually when deleting items in a collection, it's better to start at the end and go to the beginning

Try the macro in #7 and see

It starts at the end and steps to shape(1)

[cliffmichael]

Hi Paul,

Thanks for that. I will work on these recommendations. I also read the Bovey piece; I will also try out.

Thanks for the assist.

Regards, cliff

[Paul_Hossler]

NP

If it still feels slower that it should be, post a shape-filled workbook to test with

[cliffmichael]

Hi Again,

I have determined that the number of iterations is directly related to how many shapes are presently inserted onto the worksheet. If only a few, then a few iterations. If 75 shapes viewable, then 75 iterations. So, even when calling out only a few specific cell locations (well under 75) for deletion, it appears to cycle through all viewable shapes regardless.

Mana's suggestion of specifying the shapes by name to be deleted would work, however, because there are many shapes of different names, which can appear at any given cell location, it doesn't work for this application. I need to delete shapes at specific cell locations only.

[xman2000]

Hi cliffmichael , my sugestion .

activesheet.Rectangles.Select

Selection.Delete

'=======================
ActiveSheet.DrawingObjects.Select
ActiveSheet.Rectangles.Select
ActiveSheet.Lines.Select
ActiveSheet.Ovals.Select
'=======================
'http://www.excelforum.com/excel-programming-vba-macros/549032-select-multiple-shapes.html'

[Paul_Hossler]

Hi Again,

I have determined that the number of iterations is directly related to how many shapes are presently inserted onto the worksheet. If only a few, then a few iterations. If 75 shapes viewable, then 75 iterations. So, even when calling out only a few specific cell locations (well under 75) for deletion, it appears to cycle through all viewable shapes regardless.

Yes, if you use a 'For Each' loop or a 'For i = 1 to ...' loop, all 75 shapes will be iterated, unless you have some logic to test when there are no more in the cells and can Exit For

Hi Again,
Mana's suggestion of specifying the shapes by name to be deleted would work, however, because there are many shapes of different names, which can appear at any given cell location, it doesn't work for this application. I need to delete shapes at specific cell locations only.

If you add the shapes and can give the ones in the special cells a 'findable' name, Mana's will work


How long does it really take to go through 75 shapes and test .TopRightCell?

I can't imagine that it takes any time at all

[cliffmichael]

Refresh time to update is about 4-5 seconds for small quantities of shapes. With 75, it can take up to 12 seconds. Using a 'findable name' poses too much variability and, thus, way more complicated If/then conditional coding.

[snb]

Why would you delete shapes (what kind of ?) after which you copy new shapes (what kind of ?) ?

[Paul_Hossler]

Refresh time to update is about 4-5 seconds for small quantities of shapes. With 75, it can take up to 12 seconds. Using a 'findable name' poses too much variability and, thus, way more complicated If/then conditional coding.

How often do you have to delete 75 shapes?

[cliffmichael]

Hi snb,

An events-driven system-flow-diagram is generated from another worksheet, which utilizes many custom-made shapes with unique descriptors to choose from. So far, the shapes library consists of over 400 unique custom-made and individually named drawing shapes and grouped shapes (lines, arrows, rectangles, triangles, odd-shaped symbols, text boxes, etc.).

These shapes, when selected, are copied and pasted to specified cell locations (upper-left-hand-corner of a specific cell location). The placement of any given shape is representative of a specific function at a highly relevant spatial position on the worksheet . Because user selection of shapes is dependent on chosen function, many more than one shape exists, which may be alternatively selected for any given cell location.

If the user changes their mind about a particular function or its configuration, they can replace it with another function for that location. That is the purpose of deleting a previously selected shape so a new replacement shape can be inserted into that location. Thus, this is why deleting by cell location is necessary as opposed to named shape deletion.

[cliffmichael]

Hi Paul,

It is not often that all 75 shapes are deleted at once, which is essentially a worksheet reset (which is fast). As it happens, as the worksheet becomes fully populated with a completed shapes configuration, the total number of shapes will be about 50-100 shapes. When a small portion of the shapes pool is changed by the user (usually no more than 1-15 shapes to be deleted and replaced), it appears that the loop must traverse all shapes present on the worksheet; deleting the handful of specified shapes as it progresses through the total number of shapes. It's the undeleted shapes looping that's causing most of the delay.

[Paul_Hossler]

Hi Paul,

It is not often that all 75 shapes are deleted at once, which is essentially a worksheet reset (which is fast). As it happens, as the worksheet becomes fully populated with a completed shapes configuration, the total number of shapes will be about 50-100 shapes. When a small portion of the shapes pool is changed by the user (usually no more than 1-15 shapes to be deleted and replaced), it appears that the loop must traverse all shapes present on the worksheet; deleting the handful of specified shapes as it progresses through the total number of shapes. It's the undeleted shapes looping that's causing most of the delay.

I understand that part:

1. You can either mark the shapes to be deleted somehow (unique name) when they are entered onto A1 and H1 and then just delete those, or

2. You can check all the shapes to see which are in A1 and H1 and just just delete those

The Range object has no property that just contains shapes that are in it (i.e. there is not a Range("A1").ContainedShapes )