如何对VBA生成的流程图形状与箭头数组进行分组？

问题分析 #

你当前代码仅能分组最后一个形状和箭头，核心原因是Array("outer_box", "shp" & (i - 1), "arw" & (i - 1))只包含了最后一组元素的名称，未覆盖所有生成的矩形和箭头。另外无法在循环中迭代添加元素到组内——Excel的Shape组一旦创建，不能直接向其中追加新元素，必须先收集所有需要分组的成员，再一次性完成分组操作。

解决方案 #

我们可以通过动态字符串数组收集所有需分组的形状名称，最后统一执行分组，具体修改步骤如下：

1. 新增动态字符串数组，用于存储所有要分组的形状名称
2. 在创建每个矩形、箭头时，将它们的名称加入数组
3. 最后加入外框名称，通过Shapes.Range(数组).Group完成整体分组

修改后的完整代码 #

Dim i As Integer
Dim outer_box As Shape
Dim shp(20) As Shape
Dim arw(20) As Shape
Dim shpgrp As Shape
Dim rg As Range
Dim height As Long
' 新增：存储所有要分组的形状名称
Dim shapeNames() As String
Dim nameCount As Integer

With ActiveSheet
    Set rg = .Range("B11")
End With

i = 1
height = 0
nameCount = 0
If process(i - 1) = vbNullString Then
    End
Else
    For i = 1 To 20
        If process(i - 1) = vbNullString Then ' 从用户表单获取process()数组输入
            Exit For
        Else
            Set shp(i) = ActiveSheet.Shapes.AddShape(msoShapeRectangle, 1, 1, 1, 1)
            With shp(i)
                .Width = 150
                .TextFrame.HorizontalAlignment = xlHAlignLeft
                .TextFrame.VerticalAlignment = xlVAlignCenter
                .TextFrame.Characters.Text = i & ". " & process(i - 1)
                .Left = rg.Left + 5
                .Top = rg.Top + 10 + height + 20 * (i - 1)
                .Name = "shp" & i
            End With
            ' 将当前矩形名称加入数组
            nameCount = nameCount + 1
            ReDim Preserve shapeNames(1 To nameCount)
            shapeNames(nameCount) = shp(i).Name
            
            If Not i - 1 = 0 Then
                Set arw(i) = ActiveSheet.Shapes.AddConnector(msoConnectorStraight, 100, 100, 100, 100)
                With arw(i)
                    .Line.EndArrowheadStyle = msoArrowheadTriangle
                    .ConnectorFormat.BeginConnect shp(i - 1), 3
                    .ConnectorFormat.EndConnect shp(i), 1
                    .Name = "arw" & i
                End With
                ' 将当前箭头名称加入数组
                nameCount = nameCount + 1
                ReDim Preserve shapeNames(1 To nameCount)
                shapeNames(nameCount) = arw(i).Name
            End If
        End If
        height = height + shp(i).height
    Next i
    Set outer_box = ActiveSheet.Shapes.AddShape(msoShapeRectangle, 1, 1, 1, 1)
    With outer_box
        .Top = rg.Top
        .Left = rg.Left
        .Width = 160
        .height = height + 20 * (i - 1)
        .ZOrder msoSendToBack
        .Name = "outer_box"
    End With
    ' 将外框名称加入数组
    nameCount = nameCount + 1
    ReDim Preserve shapeNames(1 To nameCount)
    shapeNames(nameCount) = outer_box.Name
End If

' 使用收集好的所有形状名称数组执行分组
Set shpgrp = ActiveSheet.Shapes.Range(shapeNames).Group
shpgrp.Select
End Sub

关键说明 #

• 动态数组收集名称：通过ReDim Preserve动态扩展数组，确保所有生成的矩形、箭头和外框都被纳入分组范围
• 避免全局Shapes引用：仅使用当前流程图生成的形状名称，不会影响工作表中其他流程图的元素
• 一次性分组：所有元素准备完毕后再执行分组，这是Excel VBA中创建形状组的唯一可行方式，无法在循环中逐步向组内添加元素

内容的提问来源于stack exchange，提问作者Barbarian