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

S

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.
eAXeDStBZ6

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

Links? Where??
If Excel says you have links but you can't find them, go to Formulas, Name Manager. Look for old links to dead workbooks & delete.
Sort by date Sort by votes
s!Anxrq_k7ozqaik9j3_DlHlCE0qu2
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

y4mwblWGxWTotU5o6e984r1NFZ25k4wJM8rY3G53YXrU4V726tYU3a5wvKFVQhOfkFEM6V5zJ5JlBms-Waf27s8ZOe2X88Jj2mhEX8kGQ1bEqUxEeFL_CZ_unCjurINVUeANPqN6FPUy3WSk9ErFIcWTuQgeqssgVK_9UIo8_nbSzDSlV-n4lD0SuXYoUyFG0rwObjI8zCay2zzyarZkRE47Q
 
Last edited by a moderator:
Upvote 0
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
[Table="width:, class:head"][tr=bgcolor:#E0E0F0][th] [/th][th]
A​
[/th][th]
B​
[/th][th]
C​
[/th][th]
D​
[/th][th]
E​
[/th][th]
F​
[/th][th]
G​
[/th][th]
H​
[/th][th]
I​
[/th][th]
J​
[/th][th]
K​
[/th][th]
L​
[/th][th]
M​
[/th][/tr]
[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]
1​
[/td][td=bgcolor:#C65911][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][/tr]

[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]
2​
[/td][td=bgcolor:#C65911]Age[/td][td=bgcolor:#FFC000]
60​
[/td][td=bgcolor:#FFC000]
61​
[/td][td=bgcolor:#FFC000]
62​
[/td][td=bgcolor:#FFC000]
63​
[/td][td=bgcolor:#FFC000]
64​
[/td][td=bgcolor:#FFC000]
65​
[/td][td=bgcolor:#FFC000]
66​
[/td][td=bgcolor:#FFC000]
67​
[/td][td=bgcolor:#FFC000]
68​
[/td][td=bgcolor:#FFC000][/td][td=bgcolor:#FFC000][/td][td=bgcolor:#FFC000][/td][/tr]

[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]
3​
[/td][td=bgcolor:#C65911]ServiceYears[/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][/tr]

[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]
4​
[/td][td=bgcolor:#C65911]
5​
[/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td=bgcolor:#D9E1F2]Current[/td][td][/td][td][/td][/tr]

[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]
5​
[/td][td=bgcolor:#C65911]
6​
[/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td]service years[/td][td]
20​
[/td][td][/td][/tr]

[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]
6​
[/td][td=bgcolor:#C65911]
7​
[/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td]age[/td][td]
60​
[/td][td][/td][/tr]

[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]
7​
[/td][td=bgcolor:#C65911]
8​
[/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][/tr]

[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]
8​
[/td][td=bgcolor:#C65911]
9​
[/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][/tr]

[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]
9​
[/td][td=bgcolor:#C65911]
10​
[/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][/tr]

[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]
10​
[/td][td=bgcolor:#C65911]
11​
[/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][/tr]

[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]
11​
[/td][td=bgcolor:#C65911]
12​
[/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td=bgcolor:#E2EFDA]At Retiremet[/td][td][/td][td][/td][/tr]

[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]
12​
[/td][td=bgcolor:#C65911]
13​
[/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td]service years[/td][td]
27​
[/td][td][/td][/tr]

[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]
13​
[/td][td=bgcolor:#C65911]
14​
[/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td]age[/td][td]
67​
[/td][td][/td][/tr]

[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]
14​
[/td][td=bgcolor:#C65911]
15​
[/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][/tr]

[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]
15​
[/td][td=bgcolor:#C65911]
16​
[/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][/tr]

[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]
16​
[/td][td=bgcolor:#C65911]
17​
[/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][/tr]

[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]
17​
[/td][td=bgcolor:#C65911]
18​
[/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][/tr]

[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]
18​
[/td][td=bgcolor:#C65911]
19​
[/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][/tr]

[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]
19​
[/td][td=bgcolor:#C65911]
20​
[/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][/tr]

[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]
20​
[/td][td=bgcolor:#C65911]
21​
[/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][/tr]

[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]
21​
[/td][td=bgcolor:#C65911]
22​
[/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][/tr]

[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]
22​
[/td][td=bgcolor:#C65911]
23​
[/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][/tr]

[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]
23​
[/td][td=bgcolor:#C65911]
24​
[/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][/tr]

[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]
24​
[/td][td=bgcolor:#C65911]
25​
[/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][/tr]

[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]
25​
[/td][td=bgcolor:#C65911]
26​
[/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][/tr]

[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]
26​
[/td][td=bgcolor:#C65911]
27​
[/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][/tr]

[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]
27​
[/td][td=bgcolor:#C65911]
28​
[/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][/tr]

[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]
28​
[/td][td=bgcolor:#C65911]
29​
[/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][/tr]

[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]
29​
[/td][td=bgcolor:#C65911]
30​
[/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][/tr]

[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]
30​
[/td][td=bgcolor:#C65911]
31​
[/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][/tr]

[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]
31​
[/td][td=bgcolor:#C65911][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][td][/td][/tr]
[/table][Table="width:, class:grid"][tr][td]Sheet: Sheet1[/td][/tr][/table]

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/
 
Upvote 0
You must log in or register to reply here.

Similar threads

S
  • Question Question
a macro to insert an arrow
Replies
4
Views
689
Logit
Logit
T
  • Question Question
Printing to PDF use VBA - Was working but now different sheets are different widths
Replies
1
Views
205
Tanquen
T
M
  • Question Question
Macro or Power Automate to Identify and Move "Washes" from the "Master" Sheet to the "Washes" Sheet
Replies
0
Views
182
Madam_Xavier
M
E
  • Question Question
VBA Macro to move a shape based on the current date
Replies
1
Views
865
emmsky99
E
A
  • Solved
Calendar form cancel button passing data to worksheet
Replies
7
Views
1K
AndyEd
A

Forum statistics

Threads
1,223,893
Messages
6,175,240
Members
452,621
Latest member
Laura_PinksBTHFT

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top