Question

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

如果枢轴/切片机选择发生变化，我需要清除并重新创建这些形状。

我目前的方法有效，但速度很慢。

有没有更好的方法来清除散装形状？
注意：我确实知道所有这些形状存在的确切细胞范围。

我也应用了：

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

可以在不选择的情况下一次性删除形状，并进行一些微调。让我们想象你想删除这个矩形：

您需要做的是：

遍历所有对象
制作一个包含所有矩形名称的数组
删除数组中的对象

棘手的部分是循环遍历对象，因为你需要每次都增加你的数组，这不是一个内置的功能（比如在集合中）。 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

附加功能：

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

this guy对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

是否有更快的方法在Excel中删除形状

2 个答案: