使用链接的单元格引用对形状进行分组答案

【问题标题】：Group shapes with linked cell references使用链接的单元格引用对形状进行分组
【发布时间】：2016-05-02 21:15:52
【问题描述】：

我有多个图表和一些箭头形状（链接到 Sheet2 上的某些单元格以显示单元格的值），所有这些都放在一个合并单元格 E5 的边界内。

当我向单元格添加不同的形状甚至图表然后尝试运行代码将它们组合在一起时，此代码有效。但是我认为它似乎不适用于参考范围从枢轴开始的图表......我在这里可能错了，它可能完全是什么。

Option Explicit

Sub doit()
    Call GroupShapes(Sheet2.Cells(5, "E"))
End Sub

Sub GroupShapes(rngChart As Range)
    Dim Shp As Shape
    Dim ShpRng As ShapeRange
    Dim ShpGrp As Variant
    Dim Arr() As Variant
    Dim i As Long

    i = 1
    With rngChart.Parent
        For Each Shp In .Shapes
            If Shp.TopLeftCell.MergeArea.Row = rngChart.MergeArea.Row Then
                ReDim Preserve Arr(1 To i)
                Arr(i) = Shp.Name
                i = i + 1
            End If
        Next Shp

        Set ShpRng = .Shapes.Range(Arr)

       ' Here i get "Application defined or Object defined error"
       Set ShpGrp = ShpRng.Group

       With ShpGrp
          .Name = "shp" & VBA.Replace(rngChart.Parent.Name, " ", "")
       End With
   End With
End Sub

如果我选择所有形状，然后尝试手动或通过代码（如下所示）对它们进行分组，它会分组。我做错了什么？

Sub doit1()
Dim rngChart As Range

Sheet2.Activate
With Sheet2
    Set rngChart = .Cells(5, "E")
End With
Call GroupShapes1(rngChart)

End Sub

Sub GroupShapes1(rngChart As Range)
Dim Shp As Variant
Dim Arr() As Variant

With rngChart.Parent
    For Each Shp In .Shapes
        If Not Intersect(.Range(Shp.TopLeftCell.MergeArea.Cells, Shp.BottomRightCell.MergeArea.Cells), rngChart) Is Nothing Then
            Shp.Select Replace:=False
        End If
    Next Shp
    Set Shp = Selection.Group
End With
End Sub

我想对形状进行分组，而不是选择它们。如果有人知道为什么会发生这种情况，请提供帮助。

【问题讨论】：

标签： excel vba shapes

【解决方案1】：

我发现图表未被选中的原因是因为每个图表的名称相同，即Object13，尽管他们的 ID 不同。因此，一旦我用唯一的名称（这里 ID 就足够了）重命名每个形状和图表，就可以进行分组了。

Option Explicit 

Sub doit() 
    Call GroupShapes(Sheet2.Cells(5, "E")) 
End Sub 

Sub GroupShapes(rngChart As Range) 
Dim Shp As Shape 
Dim ShpRng As ShapeRange 
Dim ShpGrp As Variant 
Dim Arr() As Variant 
Dim i As Long i = 1 

With rngChart.Parent 
    For Each Shp In .Shapes 
        If Shp.TopLeftCell.MergeArea.Row = rngChart.MergeArea.Row Then 
            With Shp
                .Name = .Type & .ID
            End With

            ReDim Preserve Arr(1 To i) 
            Arr(i) = Shp.Name 
            i = i + 1 
        End If 
    Next Shp 

    Set ShpRng = .Shapes.Range(Arr) 
    Set ShpGrp = ShpRng.Group 

    With ShpGrp 
        .Name = "shp" & VBA.Replace(rngChart.Parent.Name, " ", "") 
    End With 
End With 
End Sub

【讨论】：