Excel 2013 VBA Shape Deletions Take Too Long To Execute RRS feed

  • Question

  • I have a worksheet with several hundred custom-made shapes selected by the user via a user form, which are programmatically copied from an adjacent worksheet and pasted to exact predetermined cell locations within the main worksheet of interest (Diagram).  The user is able to replace any shape on the Diagram at any cell location on-the-fly.  I utilize a For Each loop and Intersect Method for deletion of previously inserted shapes by specifying the exact Range by cell location to delete a specific shape(s). 

    For Each shp In Worksheets("Diagram").Shapes
            If Not Intersect(shp.TopLeftCell, Worksheets("Diagram") _
                .Range("B10")) Is Nothing Then shp.Delete
    Next shp

    This code snippet works as intended, however, perceptible delays in execution emerge as more and more shapes are added to the Diagram worksheet.  While stepping through the code, I notice that the quantity of delete loop-iterations is directly related to the quantity of shapes inserted (one-to-one relationship) within the Diagram worksheet—even though only one shape may be called for deletion. 

    Is there a different approach that will delete singular shapes without cycling through all shapes present? 

    Thanks, cliff

    Tuesday, November 8, 2016 7:38 PM

All replies

  • AFAIK the only method of making this quicker is to directly reference the shape name to be deleted.

    I don't know if you can incorporate the example code below into your project but if you can then it works.

    The first sub creates a shape and then names the shape based on the TopLeftCell address. However, because Excel does not like names that actually match address references, it is necessary to adjust the reference by adding another character like an underscore to the cell address.

    Now the second example sub can reference the shape directly by getting the name of the shape from the cell reference address and appending the underscore.

    Sub CreateShape()
        Dim lngLeft As Double
        Dim lngTop As Double
        Dim lngWdth As Double
        Dim lngHt As Double
        Dim rngShp As Range
        Dim shp As Shape
        Set rngShp = Range("B10")
        With rngShp
            'The +1 ensures that the TopLeftCell is within the required address
            'and normally it is not noticeable in the output on the screen
            'You might be able to get away without using it so test and see what occurs.
            lngLeft = .Left + 1
            lngTop = .Top + 1
            lngWdth = .Width
            lngHt = .Height
        End With
        Set shp = Worksheets("Diagram").Shapes.AddShape(msoShapeRectangle, lngLeft, lngTop, lngWdth, lngHt)
        With shp
            .Name = .TopLeftCell.Address(0, 0) & "_"    'Underscore suffix makes it different to a cell address
        End With
    End Sub

    Sub DeleteShape()
        Dim strShpName As String
        strShpName = Range("B10").Address(0, 0) & "_"
        On Error Resume Next
        If Err.Number <> 0 Then
            MsgBox "Shape " & strShpName & " not found."
        End If
    End Sub

    Regards, OssieMac

    Wednesday, November 9, 2016 4:23 AM
  • Hi tulsultant,

    I view the suggestion given by OssieMac and find that it can fulfil your requirement.

    you can see that with the use of that code you can directly able to delete the shape on the sheet without using loop.

    so it will solve your performance issue.

    if you think that suggestion given by the OssieMac can solve your issue then I suggest you to mark his suggestion as an Answer.

    if you have issue to implement this suggestion then let us know about that.



    MSDN Community Support
    Please remember to click "Mark as Answer" the responses that resolved your issue, and to click "Unmark as Answer" if not. This can be beneficial to other community members reading this thread. If you have any compliments or complaints to MSDN Support, feel free to contact MSDNFSF@microsoft.com.

    Wednesday, November 9, 2016 6:22 AM