# Moving Shapes (Arrow) with VBA, Macro, or Formula

#### ssuth9

##### New Member
Hello, I need help moving an arrow shape in my worksheet.

My Workbook has 2 Sheets:
One is a Grid to display the users Current and Projected Retirement Percentage.
The other is a Setup-sheet where the user enters their (Birth Date, Hire Date, Current Hourly Wage, Planned Retirement Date).

When the User enters their info in the Setup sheet, and then Click on the Grid Sheet it displays a Grid with Age along the Top and Years of Service down the Left.

https://www.screencast.com/t/eAXeDStBZ6
Screenshot above..
I'm using Conditional Formatting to Highlight the users Current Percentage and Retirement Percentage. with their Current and Retirement data shown to the right of the Grid.

If the Insert Image via URL worked above, you can see the Blue and Green Arrows that I want to work with.
I would like to have the Right or Beginning of the Arrow to be Anchored, and the Left or Pointer of the Arrow to Move around to follow the Highlighted Blue and Green Cells as the data changes in the Setup sheet..

I hope I have explained this well, and I hope the Insert Image via URL worked..

Thanks
Steve

### Excel Facts

How to find 2nd largest value in a column?
MAX finds the largest value. =LARGE(A:A,2) will find the second largest. =SMALL(A:A,3) will find the third smallest

#### Tom Schreiner

##### Well-known Member
Howdy. You should be able to adapt this example. If not, I'll ask you for more details.
Example workbook: 1110650.zip https://1drv.ms/u/s!Anxrq_k7ozqailDrT2qlANs-GlrK?e=tbpVeg

EDIT: I suppose that I should tell you how it works. The 100 and 200 are simply arbitrary. It's the conditional formatting that dictates where the arrows end up. Enter 100 in some cell and an arrow will be drawn from M3 to whatever cell you just entered 100 in. Same for 200, M8.

Code:
``````Const blueIsh = 15189684
Const greenIsh = 5296274

Private Sub Worksheet_Change(ByVal Target As Range)
CheckFormatsMoveMyArrows
End Sub

Sub CheckFormatsMoveMyArrows()
Application.ScreenUpdating = False
Dim s As Shape
For Each s In Shapes
If s.Name Like "Arrow*" Then s.Delete
Next

Dim c As Range
For Each c In Range("A1:K23")
If c.DisplayFormat.Interior.Color = blueIsh Then
With Shapes.AddConnector(msoConnectorStraight, Range("M3").Left, Range("M3").Top + Range("M3").Height / 2, c.Left + c.Width, c.Top)
.Name = "ArrowBlue"
End With
ElseIf c.DisplayFormat.Interior.Color = greenIsh Then
With Shapes.AddConnector(msoConnectorStraight, Range("M8").Left, Range("M8").Top + Range("M8").Height / 2, c.Left + c.Width, c.Top)
.Name = "ArrowGreen"
End With
End If
Next
Application.ScreenUpdating = True
End Sub``````

Last edited:

#### ssuth9

##### New Member
Thank you, I will try to work it in to my spreadsheet..

Steve

#### Yongle

##### Well-known Member
A different approach which works for me

Amend the various ranges to match your worksheet:
Age in row2 and service in columnA
Tail of arrows K4 & K11
Current values in L5 & L6
Retirement values in L12 & L13

Match function used to identify "head of arrow" cell
Old arrows deleted and new arrows created each time

my test worksheet:

Excel 2016 (Windows) 32 bit
A
B
C
D
E
F
G
H
I
J
K
L
M
1
2
Age
60​
61​
62​
63​
64​
65​
66​
67​
68​
3
ServiceYears
4
5​
Current
5
6​
service years
20​
6
7​
age
60​
7
8​
8
9​
9
10​
10
11​
11
12​
At Retiremet
12
13​
service years
27​
13
14​
age
67​
14
15​
15
16​
16
17​
17
18​
18
19​
19
20​
20
21​
21
22​
22
23​
23
24​
24
25​
25
26​
26
27​
27
28​
28
29​
29
30​
30
31​
31
 Sheet: Sheet1

Code:
``````Sub Arrow()
'variables
Dim Blue As Range, Green As Range, B As Range, G As Range, Shp As Shape
'set ranges
Set B = [[COLOR=#ff0000]K4[/COLOR]]
Set G = [[COLOR=#ff0000]K11[/COLOR]]
With WorksheetFunction
Set Blue = Cells(.Match([[COLOR=#008080]L5[/COLOR]], [[COLOR=#0000cd]A:A[/COLOR]], 0), .Match([[COLOR=#008080]L6[/COLOR]], [[COLOR=#0000cd]2:2[/COLOR]], 0))
Set Green = Cells(.Match([[COLOR=#800080]L12[/COLOR]], [[COLOR=#0000cd]A:A[/COLOR]], 0), .Match([[COLOR=#800080]L13[/COLOR]], [[COLOR=#0000cd]2:2[/COLOR]], 0))
End With
'delete old arrows
For Each Shp In ActiveSheet.Shapes
If Left(Shp.Name, 14) = "Straight Arrow" Then Shp.Delete
Next
'new arrows
Call Arrows(B, Blue, RGB(0, 0, 255))
Call Arrows(G, Green, RGB(0, 255, 0))
'de-select arrow
[K5].Activate
End Sub

Private Sub Arrows(FromRange As Range, ToRange As Range, RGBcolor As Long)
Dim left1 As Double, left2 As Double, top1 As Double, top2 As Double, width2 As Double
'cell positions
left1 = FromRange.Left
left2 = ToRange.Left
top1 = FromRange.Top
top2 = ToRange.Top
width2 = ToRange.Width
ActiveSheet.Shapes.AddConnector(msoConnectorStraight, left1, top1, left2 + width2, top2).Select
With Selection.ShapeRange.Line
.Weight = 1.75
.Transparency = 0.5
.ForeColor.RGB = RGBcolor
End With
End Sub``````
arrow creation code is based on something I found here:
https://wellsr.com/vba/2015/excel/draw-lines-or-arrows-between-cells-with-vba/