按 VBA Excel 中的形状对象对形状进行分组

Question

我在 Excel 中使用 VBA 按名称对形状进行分组时遇到问题。
发生这种情况是因为我有多个可以具有相同名称的形状。

以下代码可以重现我的问题。
您可以取消注释行 OriginalShape.Name = "MyShape" 以查看错误。

Sub test()
    
    ' Create Original Shape
    Dim OriginalShape As Shape
    Set OriginalShape = Sheet1.Shapes.AddShape(msoShapeRectangle, 5, 20, 50, 50)
    
    ' Rename Shape to simulate my project
'    OriginalShape.Name = "MyShape" ' Uncomment line to recreate problem
    
    ' Copy and Paste Shape (I believe there is no other way to do this)
    OriginalShape.Copy
    Sheet1.Paste Sheet1.Range("C2")
    
    ' Get Object of Last Pasted Shape
    Dim CloneShape As Shape
    Set CloneShape = Sheet1.Shapes(Sheet1.Shapes.Count)
    
    ' Group Shapes
    Dim ShapeGroup As Shape
    Set ShapeGroup = Sheet1.Shapes.Range(Array(OriginalShape.Name, CloneShape.Name)).Group

End Sub

我知道我也可以使用形状索引，比如 Sheet1.Shapes.Range(Array(1, 2)).Group，但这似乎也不是一个好方法，因为我需要为每个形状存储一个变量（形状索引）除了形状对象。

有没有办法以其他方式对形状进行分组，例如通过对象或 ID。我相信最好的是这样的。

Set ShapeGroup = Sheet1.Shapes.Range(Array(OriginalShape, CloneShape)).Group
'OR
Set ShapeGroup = Sheet1.Shapes.Range(Array(OriginalShape.ID, CloneShape.ID)).Group

Answer 1

正如 Tim Williams 所说：代码失败，因为组数组由相同的名称组成。您需要做的是在创建形状时将索引添加到名称中

这会起作用：

Sub test()
    
   
    Const cntShapes As Long = 2
    
    
    Dim i As Long, shp As Shape, cTarget As Range
    Dim arrShapeNames(1 To cntShapes) As Variant
    
    With Sheet1
        For i = 1 To cntShapes
            Set cTarget = .Cells(1, i)   'adjust this to your needs
            Set shp = .Shapes.AddShape(msoShapeRectangle, cTarget.Left, cTarget.Top, 50, 50)
            shp.Name = "MyShape." & i   'adding the index to the name makes it unique
            arrShapeNames(i) = shp.Name
        Next
    End With
    
    
    ' Group Shapes
    Dim ShapeGroup As Shape
    Set ShapeGroup = Sheet1.Shapes.Range(arrShapeNames).Group

End Sub

按 VBA Excel 中的形状对象对形状进行分组

Group Shapes by Shape Object in VBA Excel

excel

vba

shapes