如何修改VBA代码实现选中区域顶部至底部的居中箭头绘制

直接上修改后的代码，现在可以针对单个选中区域，从它的顶部中点垂直向下画到底部中点：

Sub test()
    ' 检查是否有选中区域
    If TypeName(Selection) <> "Range" Then
        MsgBox "请先选中一个单元格区域！"
        Exit Sub
    End If
    CREATE_ARROW Selection
End Sub

Sub CREATE_ARROW(ByVal targetRng As Range)
    Dim MyArrow As Shape
    ' 计算起点：区域顶部居中
    Dim startX As Double, startY As Double
    startX = targetRng.Left + targetRng.Width / 2
    startY = targetRng.Top
    
    ' 计算终点：区域底部居中
    Dim endX As Double, endY As Double
    endX = targetRng.Left + targetRng.Width / 2
    endY = targetRng.Top + targetRng.Height
    
    ' 添加直线箭头
    Set MyArrow = ActiveSheet.Shapes.AddConnector(msoConnectorStraight, _
        startX, startY, endX, endY)
    
    ' 设置箭头样式（可根据需求调整）
    MyArrow.Line.EndArrowheadStyle = msoArrowheadOpen
    ' 可选：设置线条粗细、颜色
    ' MyArrow.Line.Weight = 1.5
    ' MyArrow.Line.ForeColor.RGB = RGB(255, 0, 0)
    
    Set MyArrow = Nothing
End Sub

关键修改说明 #

• 把原代码的双区域参数改成单个目标区域参数，因为只需要在同一个区域内绘制垂直箭头
• 起点坐标取区域的顶部边界+水平居中（targetRng.Top 是区域最顶端的位置，targetRng.Left + targetRng.Width/2 保证水平居中）
• 终点坐标取区域的底部边界+水平居中（targetRng.Top + targetRng.Height 是区域最底端的位置）
• 新增了选中区域的判断，避免无选中时报错

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