具有链接单元格引用的组形状

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 

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

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 

我想分组形状，而不选择它们。如果任何人有任何想法为什么会发生这种情况，请协助。

Answer 1

我发现图表未被选中的原因是因为每个图表都被命名为相同的I.e. 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