CODEWITHSUNDEEP
vbaexcel
MiguelH
MiguelH

Reputation: 1425

Is there a faster method of deleting shapes in Excel

I've successfully added shapes into cells (msoShapeOval) in a pivot table.

I need to clear and recreate these shapes if the pivot / slicer selection changes.

My current method works, but it is slow.

Is there any better method to clear shapes in bulk?
Note: I do know the exact cell range where all these shapes exist.

I've also appied :

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False

Current code:

  Dim Shp as Shape
  For Each Shp In rng.Parent.Shapes
     If InStrB(Shp.Name, "$") > 0 Then Shp.Delete
  Next

Upvotes: 1

Views: 1232

Answers (2)

Vityata
Vityata

Reputation: 43575

It is possible to delete the shapes at once without selecting, with some fine tuning. Let's imagine you want to delete the rectangulars from this:

enter image description here

What you need to do is the following:

  • loop through all the objects
  • make an array with all the rectangular's names
  • delete the objects in the array

Tricky part is the looping through the objects, because you need to increment your array every time, which is not a built-in functionality (like in collection). incrementArray is the function for this.

Furthermore, the first time you increment to the unassigned array, you need to check whether it is allocated (achieved with the IsArrayAllocated function below).

Option Explicit

Sub TestMe()

    Dim shp             As Shape
    Dim arrOfShapes()   As Variant 'the () are important!

    With ActiveSheet
        For Each shp In .Shapes
            If InStrB(shp.Name, "Rec") > 0 Then
                arrOfShapes = incrementArray(arrOfShapes, shp.Name)
            End If
        Next
        If IsArrayAllocated(arrOfShapes) Then
            Debug.Print .Shapes.Range(arrOfShapes(0)).Name
            .Shapes.Range(arrOfShapes).Delete
        End If
    End With
End Sub

The additional functions:

Public Function incrementArray(arrOfShapes As Variant, nameOfShape As String) As Variant

    Dim cnt         As Long
    Dim arrNew      As Variant

    If IsArrayAllocated(arrOfShapes) Then
        ReDim arrNew(UBound(arrOfShapes) + 1)            
        For cnt = LBound(arrOfShapes) To UBound(arrOfShapes)
            arrNew(cnt) = CStr(arrOfShapes(cnt))
        Next cnt
        arrNew(UBound(arrOfShapes) + 1) = CStr(nameOfShape)
    Else
        arrNew = Array(nameOfShape)
    End If

    incrementArray = arrNew

End Function

Function IsArrayAllocated(Arr As Variant) As Boolean
    On Error Resume Next
    IsArrayAllocated = IsArray(Arr) And _
                       Not IsError(LBound(Arr, 1)) And _
                       LBound(Arr, 1) <= UBound(Arr, 1)

End Function

Credits to this guy for the finding that the arrOfShapes should be declared with parenthesis (I have spent about 30 minutes researching why I could not pass it correctly) and to CPearson for the IsArrayAllocated().

Upvotes: 3

JohnyL
JohnyL

Reputation: 7122

To delete all shapes except slicers:

Sub RemoveAllExceptSlicers()

    Dim sh As Shape

    For Each sh In ActiveSheet.Shapes
        If Not sh.Type = MsoShapeType.msoSlicer Then
            sh.Delete
        End If
    Next

End Sub

Upvotes: 0

Related Questions