Group Shapes by Shape Object in VBA Excel-CodePudding

I'm having problems in grouping shapes by name with VBA in Excel. This happens because I have multiple shapes that can have the same name.

The following code can recreate my problem. You can uncomment line OriginalShape.Name = "MyShape" to see the error.

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

I know I also have to possibility to use Shape indexes, like Sheet1.Shapes.Range(Array(1, 2)).Group, but this is doesn't seem a good way either, as I would need to store one more variable for each shape (the shape index) apart from the shape Object.

I would like know if there is a way to group shapes by in some other way, like through Object or ID. I believe that the best would be use something like.

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

Can someone help me? Thank you in advance.

CodePudding user response：

Like Tim Williams said: the code fails, as the group-array consists of equal names. What you need to do, is adding the index to the name while creating the shapes

This will work:

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