Excel 2013 VBA形状删除需要太长时间才能执行 [英] Excel 2013 VBA Shape Deletions Take Too Long To Execute

问题描述

我有一个工作表，用户通过用户表单选择了几百个自定义形状，这些形状以编程方式从相邻工作表复制并粘贴到感兴趣的主工作表中的确切预定单元格位置（图）  
用户可以在任何单元格位置即时替换图表上的任何形状。 我利用For Each循环和相交方法删除先前插入的形状，方法是通过单元格位置指定精确的范围来删除特定形状。 

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? 

谢谢，悬崖

推荐答案

AFAIK使这个更快的唯一方法是直接引用要删除的形状名称。

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.

  first sub 创建一个形状，然后根据TopLeftCell地址命名形状。但是，因为Excel不喜欢实际匹配地址引用的名称，所以必须通过向单元格地址添加另一个字符
（如下划线）来调整引用。

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.

现在第二个示例sub可以直接通过从单元格引用地址获取形状名称并附加下划线来直接引用形状。

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

   

   设置rngShp =范围（"B10"）

   使用rngShp为
        '+1确保TopLeftCell在所需地址内。
        '并且通常在屏幕输出中不明显
为
        '你可以在不使用它的情况下离开，所以测试并看看发生了什么。

        lngLeft = .Left + 1

        lngTop = .Top + 1

        lngWdth = .Width

        lngHt = .Height

   结束与$
   设置shp =工作表（" Diagram"）。Shapes.AddShape（msoShapeRectangle，lngLeft，lngTop，lngWdth，lngHt）

   使用shp

        .Name = .TopLeftCell.Address（0,0）& " _"    '下划线后缀使其与单元格地址不同

   结束与$
结束子

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 =范围（"B10"）。地址（0,0）& "_"

    On Error Resume Next

   工作表（"图表"）。形状（strShpName）。删除

   如果Err.Number<> 0然后

        MsgBox"Shape" &安培; strShpName& "找不到。"

   结束如果是
End Sub

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

这篇关于Excel 2013 VBA形状删除需要太长时间才能执行的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！