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

Question

我有多个图表和一些箭头形状（链接到 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

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

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

我想对形状进行分组，而不是 selecting 它们。如果有人知道为什么会这样，请提供帮助。

Answer 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

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

Group shapes with linked cell references

excel

vba

shapes