Is there a faster method of deleting shapes in Excel - vba

Question

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

Answer 1

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:
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().

Answer 2

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