VBA宏开发求助：实现点击按钮生成连续关联形状功能

已实现选择单元格生成单个形状的基础上，补充生成3个额外形状，每个形状起始位置为上一个形状结束位置的下一行，修改后的完整代码如下：

Sub TrialwithDate()
    Dim rng As Range
    Dim shp As Shape
    Dim currentTop As Double
    Dim shapeWidth As Double
    Dim shapeHeight As Double
    Dim i As Integer
    
    ' 选择起始单元格
    Set rng = Application.InputBox("Choose starting point", Type:=8)
    
    ' 初始化形状尺寸
    shapeWidth = Range("K36").Value * 80
    shapeHeight = 37
    currentTop = rng.Top ' 第一个形状的起始垂直位置
    
    ' 循环生成4个形状（1个基础+3个额外）
    For i = 1 To 4
        ' 添加形状到当前位置
        Set shp = ActiveSheet.Shapes.AddShape(msoShapeRoundedRectangle, rng.Left, currentTop, shapeWidth, shapeHeight)
        
        ' 设置样式
        With shp
            .TextFrame2.TextRange.Text = "Test " & i ' 给形状加序号区分
            .TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(0, 0, 0)
            .TextFrame2.TextRange.Font.Size = 11
            .Fill.ForeColor.RGB = RGB(146, 208, 80)
            .TextFrame.HorizontalAlignment = xlHAlignCenter
            .TextFrame.VerticalAlignment = xlVAlignCenter
        End With
        
        ' 计算下一个形状的起始位置：上一个形状底部即为下一行起始位置
        currentTop = shp.Top + shp.Height
    Next i
End Sub

关键修改说明 #

• 新增循环逻辑：通过For i = 1 To 4一次性生成4个形状，满足需求
• 跟踪位置变量：用currentTop记录每个形状的起始垂直位置，初始值为选中单元格的顶部
• 位置计算逻辑：每次生成形状后，将currentTop更新为当前形状的底部（shp.Top + shp.Height），确保下一个形状从上一个形状结束位置的下一行开始
• 区分形状：给每个形状的文本添加序号，方便识别不同形状

如果需要让形状之间间隔一行，只需将位置计算行改为：

currentTop = shp.Top + shp.Height + rng.RowHeight

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