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



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

[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 (http://www.vbaexpress.com/forum/member.php?60542-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 )

[Jan Karel Pieterse]

You might be suffering from redrawing of the shapes after every delete. (even though screenupdating is turned off). Try temporarily activating another worksheet.

[snb]

I'm not disappointed using:
(assuming the shapes that have to be copied to sheet1 are being selected in sheet2.


Sub M_snb()
Do Until Sheet1.Shapes.Count = 0
Sheet1.Shapes(1).Delete
Loop

For j = 1 To Selection.ShapeRange.Count
With Selection.ShapeRange(j).Duplicate
.Cut
Sheet1.Paste Sheet1.Cells(10 * j, 2)
End With
Next
End Sub

[cliffmichael]

I think option #1 will be too painful to code given the up-to-a-dozen different named shapes that could reside in any given cell location. #2 is interesting but I am unsure of how to accomplish.

If I understand #2 construct correctly, when the user executes a change event and before the delete-previous-shapes code, a query of that selected cell must be made to determine if a shape is already associated with it and what is its name. Then, whatever shape name was captured would be carried into the delete function by name. I think that could work well for my application. The only issue is how complex would that code be. At present, there are over 50 events, which will require this treatment. The other issue is it is a serious stretch for my present programming skill.

[Paul_Hossler]

There is something else going on I think, other than the Shape deletes

This is just a macro that deletes shapes in A1 out of approx 100 on the sheet

It runs in microseconds though all the shapes on the sheet to delete the ones that have the top left cell in A1


Try to attachment to see if it deletes the shapes quickly for you

If it does, than I think we need to see if there is anything else happening that is bogging it down




Option Explicit

Private Declare Function QueryPerformanceFrequency Lib "kernel32.dll" (lpFrequency As Currency) As Long
Private Declare Function QueryPerformanceCounter Lib "kernel32.dll" (lpPerformanceCount As Currency) As Long

Sub test()
Dim oShape As Shape
Dim TimerFreq As Currency, TimerStart As Currency, TimerEnd As Currency, TimerDuration As Currency

Application.ScreenUpdating = False
Application.EnableEvents = False

QueryPerformanceCounter TimerStart

For Each oShape In Worksheets("Sheet1").Shapes
If oShape.TopLeftCell.Address = "$A$1" Then oShape.Delete
Next

QueryPerformanceFrequency TimerFreq
QueryPerformanceCounter TimerEnd


Application.EnableEvents = False
Application.ScreenUpdating = True

TimerDuration = (TimerEnd - TimerStart) / TimerFreq
MsgBox TimerDuration & " microseconds"
End Sub

[cliffmichael]

You might be suffering from redrawing of the shapes after every delete. (even though screenupdating is turned off). Try temporarily activating another worksheet.

Hi Jan. The shapes are copied from a different worksheet and pasted into the main worksheet of interest and this occurs very well after the delete-previous-shapes procedure.

[Jan Karel Pieterse]

I don't see how that relates to my remark at all I'm afraid :-)

[cliffmichael]

Hi Paul,

I've attached a sample file, which illustrates the repeated iterations of deletions that are dependent on how many shapes are already displayed and not how many shapes are being called to delete. It uses a user form on the "Diagram" tab. When you monitor F8 step with all three placeholder shapes selected, you will see the repeat iterations in deleting.

Regards, cliff

[Paul_Hossler]

The logic is a little hard for me to follow, but what I think you're seeing are the other event handlers (each with a delete shapes loop) that are being called when another event handler fires

For example, in UserForm_Initialize, when .Opt_Fill_No = True is executed then Opt_Fill_No_Click is executed which also has a bunch of delete shapes

I put a break point on 2 lines (red) and single stepped through. When the yellow line was being executed, I looked at the call stack to trace back just to check

Normally, I'd use Application.EnableEvents = False to avoid secondary event handlers from cascading, but I don't understand enough about the macro to do that.

But ... I think that's what you're seeing (possibly)

17472

[HPI]

Hi folks,

maybe this is important:

I have put about 500 textfields to one sheet and linked via onAction different makros to them.

200 textfields are set to Visible=false (for later use).

When all these unvisible textfields were set to the same Position (top= and left=1), the time until another makro starts (one of the other textfields) is very slow (Maybe for searching the textfields?).

Solution/workaraound:
When these unvisible textfields were set to different positions (first textfield at top=1/left=1, second textfield at top=2/left=2 and so on) the start time of one of the other makro is very fast/normal!

Can anyone confirm this?

HPI

[Paul_Hossler]

1. Welcome to the forums - take a minute to read the hints and FAQs in my signature

2. This is a 2-3 year old post. It's better that you start your own new thread using the [+Post New Thread] near top left. You'll get better visibility and probably better answers that way.

3. Also an attached example can explain better sometimes

4. If it were me, I'd NEVER put that many text boxes on one sheet, each with a OnAction macro -- no wonder it's slow

5. Suggest you re-think your architecture. For example, I've used a protected worksheet with the input cells unlocked to collect inputs. The single WorkSheet_Change event could handle the different cells

[JimmyTheHand]

nothing