ＥＸＣＥＬ 範囲指定後矢印線を引くマクロの作り方

質問

範囲選択した任意（例：Ａ１～Ｃ１）のセルに、オートシェイプの矢印線を自動的に引くマクロの作り方を教えて下さい。
できれば、矢印線の始点にオートシェイプの丸（黒丸ではなく白丸）も一緒に引けるマクロも教えて下さい。
範囲指定するセルの長さは一定ではなく、長さがいろいろになります。
工程表を作成するにあたり、同じ手順を繰り返す為、マクロ化したいです。

回答No.1

misatoanna · ベストアンサー

横方向のみですが、

Sub Test()
　　Dim TP, LF, WD
　　TP = Selection.Top + (Selection.Height / 2)
　　LF = Selection.Left
　　WD = Selection.Width
　　ActiveSheet.Shapes.AddShape(msoShapeOval, LF, TP - 3, 6, 6).Select
　　ActiveSheet.Shapes.AddLine(LF + 6, TP, LF + WD, TP).Select
　　Selection.ShapeRange.Line.EndArrowheadStyle = msoArrowheadTriangle
End Sub

お礼

解決です。完璧です。ありがとうございました。
ここ1ヶ月間悶々と悩んでいたのです。
このＶＢＡの記述内容が理解できるように精進いたします。

回答No.2

komet163

こんにちは。
選択範囲の始点列中央から終点列中央へ、
選択範囲の縦中央を通り、始点が白丸の矢印を作成します。
○の直径は、選択範囲の第１行の高さに係数を掛けています。

その他 細かい点は、「マクロの記録」を参考にご自分でカスタマイズしてください。
またマクロの登録方法もお任せします。

Sub Macro1()
Dim rRng As Range
Dim X(1) As Single
Dim Y As Single
Dim D As Single
Dim shpRef(1) As Shape
Dim iColor As Long
Dim i As Long

On Error Resume Next
Set rRng = Selection
If Err Then Exit Sub
On Error GoTo 0

iColor = 8 '色
With rRng
With .Rows(1)
D = .Height * 0.75 '丸の直径 係数
End With
If .Columns.Count = 1 Then Exit Sub
With .Columns(1)
X(0) = .Left + .Width / 2
End With
With .Columns(.Columns.Count)
X(1) = .Left + .Width / 2
End With
Y = .Top + .Height / 2
End With

With ActiveSheet.Shapes
Set shpRef(0) = .AddLine(X(0) + D / 2, Y, X(1), Y)
Set shpRef(1) = .AddShape(msoShapeOval, X(0), Y, D, D)
With shpRef(1)
.Top = .Top - .Height / 2
.Left = .Left - .Width / 2
End With
End With
For i = 0 To 1
With shpRef(i)
.Fill.Visible = msoFalse
.Line.Weight = 1#
.Line.DashStyle = msoLineSolid
.Line.Style = msoLineSingle
.Line.Transparency = 0#
.Line.Visible = msoTrue
.Line.ForeColor.SchemeColor = iColor
.Visible = msoCTrue
End With
Next
With shpRef(0).Line
.EndArrowheadStyle = msoArrowheadTriangle
.EndArrowheadLength = msoArrowheadLengthMedium
.EndArrowheadWidth = msoArrowheadWidthMedium
End With
ActiveSheet.Shapes.Range(Array(shpRef(0).Name, shpRef(1).Name)).Select
With Selection.ShapeRange
.Group.Select
.LockAspectRatio = msoTrue
End With
rRng.Select
End Sub

お礼

ありがとうございます。