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

ssuth9

New Member
Joined
Sep 24, 2019
Messages
3
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
 

Tom Schreiner

Well-known Member
Joined
Mar 18, 2002
Messages
6,867
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"
                .Line.EndArrowheadStyle = msoArrowheadTriangle
            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"
                .Line.EndArrowheadStyle = msoArrowheadTriangle
            End With
        End If
    Next
    Application.ScreenUpdating = True
End Sub
 
Last edited:

Yongle

Well-known Member
Joined
Mar 11, 2015
Messages
4,249
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
 'add arrow
    ActiveSheet.Shapes.AddConnector(msoConnectorStraight, left1, top1, left2 + width2, top2).Select
    With Selection.ShapeRange.Line
        .BeginArrowheadStyle = msoArrowheadNone
        .EndArrowheadStyle = msoArrowheadOpen
        .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/
 

Forum statistics

Threads
1,077,850
Messages
5,336,742
Members
399,100
Latest member
darcob

Some videos you may like

This Week's Hot Topics

Top