Solved: Draw Arrow Length of Cell Selection

[JoeMoe]

I'm trying to develop some VBA code that will allow me to draw an arrow the length of a selected range (whether two cells or two hundred cells).

I have already developed code that will draw the arrow as I want it to be drawn, but I want to be able to use this regularly to draw arrows next to varying ranges in different spreadsheets, so I want to be able to select a range and then activate the macro to draw the line. Right now, I have to enter the start/end cell in the code. As an intermediate step, I am planning to use a userform to specify the ranges, but the ultimate goal is to only need to highlight the range and have the macro do the rest.

Any assistance configuring the macro to only need the range to be highlighted would be appreciated.

Here is the current code:

[vba]
Sub LineDownv2()

Dim X1 As Long
Dim X2 As Long
Dim Y1 As Long
Dim Y2 As Long

Dim Line1 As Shape

Dim mX1 As Long
Dim mY1 As Long
Dim mX2 As Long
Dim mY2 As Long

Dim Line2 As Shape

With Range("B1")
X1 = .Left + .Width / 2
Y1 = .Top
End With

With Range("B8")
X2 = .Left + .Width / 2
Y2 = .Top + .Height - 1.5
End With

With ActiveSheet.Shapes
' Get the return value and create the line.
Set Line1 = .AddLine(X1, Y1, X2, Y2)
Line1.Line.Weight = 1
Line1.Line.BeginArrowheadStyle = msoArrowheadNone
Line1.Line.EndArrowheadStyle = msoArrowheadOpen
Line1.Line.EndArrowheadWidth = msoArrowheadWidthMedium
Line1.Line.EndArrowheadLength = msoArrowheadLengthMedium
Line1.Line.ForeColor.RGB = RGB(0, 0, 255)
End With
With Range("B8")
mX1 = .Left + .Width / 2 - 4
mX2 = .Left + .Width / 2 + 4
mY1 = .Top + .Height - 1
mY2 = .Top + .Height - 1
End With

With ActiveSheet.Shapes
Set Line2 = .AddLine(mX1, mY1, mX2, mY2)
Line2.Line.Weight = 1
Line2.Line.ForeColor.RGB = RGB(0, 0, 255)
End With

End Sub
[/vba]

Also, if someone knows how to easily group the two objects that are created (arrow + line at bottom) that would also be helpful.

Thanks in advance.

[Kenneth Hobs]

Welcome to the forum!

If it is just for vertical lines in one column then select the vertical block and run:
[VBA]Sub LineDownv2()

Dim X1 As Long
Dim X2 As Long
Dim Y1 As Long
Dim Y2 As Long

Dim Line1 As Shape

Dim mX1 As Long
Dim mY1 As Long
Dim mX2 As Long
Dim mY2 As Long

Dim Line2 As Shape

Dim lCell As Range
Set lCell = Selection.Cells(Selection.Rows.Count, Selection.Columns.Count) 'Last Cell

With Selection 'First cell
X1 = .Left + .Width / 2
Y1 = .Top
End With

With lCell
X2 = .Left + .Width / 2
Y2 = .Top + .Height - 1.5
End With

With ActiveSheet.Shapes
' Get the return value and create the line.
Set Line1 = .AddLine(X1, Y1, X2, Y2)
Line1.Line.Weight = 1
Line1.Line.BeginArrowheadStyle = msoArrowheadNone
Line1.Line.EndArrowheadStyle = msoArrowheadOpen
Line1.Line.EndArrowheadWidth = msoArrowheadWidthMedium
Line1.Line.EndArrowheadLength = msoArrowheadLengthMedium
Line1.Line.ForeColor.RGB = RGB(0, 0, 255)
End With
With lCell
mX1 = .Left + .Width / 2 - 4
mX2 = .Left + .Width / 2 + 4
mY1 = .Top + .Height - 1
mY2 = .Top + .Height - 1
End With

With ActiveSheet.Shapes
Set Line2 = .AddLine(mX1, mY1, mX2, mY2)
Line2.Line.Weight = 1
Line2.Line.ForeColor.RGB = RGB(0, 0, 255)
End With

End Sub
[/VBA]

[JoeMoe]

That works perfectly! Thanks!

[GTO]

Greetings Joe,

Once solved, under the Thread Tools button (right above your first post) has a 'Solved' option.

Please let me echo Kenneth's "Welcome!" to the forum. There are some really nice folks here, who will be most helpful.

Mark