セルの中に良い感じで線矢印を描画したい

セルの中に良い感じで、線矢印を描画したい状況に遭遇した。

たまに、↓ こんな線矢印を見かけることがある。

1. 始点と終点が揃っていない。
2. みんな、微妙に傾いている。

これはぜひとも避けたい。ということで、かつて作成したマクロもあったのだが、敢えて「今作るなら」ということで再作成してみた。

【仕　様】

1. 選択したセルの中心を通るよう、水平または垂直の線矢印を描画する。
2. 引数は描画対象となるセル および 線矢印の向き。

少し前なら、独自のEnumをこしらえて向きを指定したことだろうが、最近は少し好みが変わった。せっかくExcel が準備してくれたもの（XlDirection）があるので、これを利用するとしよう。

Option Explicit
Function SetArrow(target_range As Range, _
         Optional arrow_direction As XlDirection = xlToRight) As Excel.Shape

    Dim Arrow As Excel.Shape
    ' 線矢印の始点。
    Dim Sx As Double, Sy As Double
    ' 線矢印の終点。
    Dim Ex As Double, Ey As Double

        Select Case arrow_direction
            ' 垂直：上から下へ
            Case XlDirection.xlDown
                Sx = target_range.Left + 0.5 * target_range.Width
                Sy = target_range.Top
                Ex = Sx
                Ey = Sy + target_range.Height
            ' 垂直：下から上へ
            Case XlDirection.xlUp
                Sx = target_range.Left + 0.5 * target_range.Width
                Sy = target_range.Top + target_range.Height
                Ex = Sx
                Ey = target_range.Top
            ' 水平：左から右へ
            Case XlDirection.xlToRight
                Sx = target_range.Left
                Sy = target_range.Top + 0.5 * target_range.Height
                Ex = Sx + target_range.Width
                Ey = Sy
            ' 水平：右から左へ
            Case XlDirection.xlToLeft
                Sx = target_range.Left + target_range.Width
                Sy = target_range.Top + 0.5 * target_range.Height
                Ex = target_range.Left
                Ey = Sy
        End Select

        ' 線矢印を描画。
        Set Arrow = ActiveSheet.Shapes.AddConnector(msoConnectorStraight, Sx, Sy, Ex, Ey)
        With Arrow.Line
            .EndArrowheadStyle = msoArrowheadTriangle
            .ForeColor.ObjectThemeColor = msoThemeColorText1
            .Weight = 0.5
        End With

        Set SetArrow = Arrow
End Function

早速、テストしてみよう。

Sub test()
    SetArrow Range("A1"), xlDown
    SetArrow Range("A2"), xlToLeft
    SetArrow Range("A3"), xlToRight
    SetArrow Range("A4"), xlUp    
    SetArrow Range("A6:E6"), xlToRight
End Sub

思った位置に、きれいに線矢印を描画することが出来ました。

参考まで。