有没有更快的方法来删除Excel中的形状

我已经成功地将形状添加到数据透视表中的单元格（msoShapeOval）。

如果pivot / slicer的select发生变化，我需要清除并重新创build这些形状。

我目前的方法工作，但它是缓慢的。

有没有更好的方法来清除散装的形状？
注意：我知道所有这些形状存在的确切单元格区域。

我也接受了：

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

当前代码：

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

Answer 1

可以一次删除形状而不用select，并进行一些微调。 假设你想从这里删除这个矩形：

你需要做的是以下几点：

• 遍历所有的对象
• 用所有矩形的名字组成一个数组
• 删除数组中的对象

棘手的部分是通过对象循环，因为你需要增加你的数组，每一次，这不是一个内置的function（如集合）。 incrementArray是这个函数。

而且，当你第一次增加未分配的数组时，你需要检查它是否被分配（用下面的IsArrayAllocated函数来实现）。

 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 

附加function：

 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 

感谢这个人发现arrOfShapes应该用圆括号（我花了大约30分钟研究为什么我不能正确传递）和CPearson为IsArrayAllocated() 。

Answer 2

删除切片机以外的所有形状：

 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