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

[ssuth9]

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

 

[Legacy 98055]

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.

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

 

[ssuth9]

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

Steve

 

[Yongle]

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

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/

 

[ssuth9]

Yes Thank you.. I found that same post..

I asked Ryan from "wellsr.com" for help as well, and he gave me a Solution that when I pasted the Code to my Sheet it work the first time..
https://ask.wellsr.com/928/draw-lines-or-arrows-between-cells

Thanks again..

 

[Yongle]

Glad you have been successful