Блог

У меня возникли проблемы с группировкой фигур по имени с помощью VBA в Excel.
Это происходит потому, что у меня есть несколько фигур, которые могут иметь одно и то же имя.

Следующий код может воссоздать мою проблему.
Вы можете раскомментировать строку 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 , но это тоже не кажется хорошим способом, так как мне нужно было бы хранить еще одну переменную для каждой фигуры (индекс фигуры) отдельно от объекта фигуры.

Есть ли способ группировать фигуры каким-либо другим способом, например, с помощью объекта или идентификатора. Я считаю, что лучшим было бы что-то вроде.

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

Как сказал Тим Уильямс: код не работает, так как массив групп состоит из одинаковых имен. Что вам нужно сделать, так это добавить индекс к имени при создании фигур

Это сработает:

 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." amp; 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