Change arrow direction on a shape based on a cell value

[kilito]

Hi everyone,
I am not an expert in vba and looking for some help to understand why my code is not working. I have inserted a shape line with an arrow head and trying to change the direction of the arrow based on a cell value (positive or negative number).
The shape name is : test
the value is in cell: A1
My Vb code:

Sub arrow()
With ActiveSheet.Shapes("test").Select
If Range("A1") > 0 Then
.BeginArrowheadStyle = msoArrowheadNone
.EndArrowheadStyle = msoArrowheadTriangle
Else
.BeginArrowheadStyle = msoArrowheadTriangle
.EndArrowheadStyle = msoArrowheadNone
End If
End With
End Sub

The error I receive is: object required.

I am not sure what is missing in my code to work smoothly :-)

Thank you in advance for your help and suggestions.

Cheers

[TMS]

I'd guess you need to remove .Select.

If that does't work ...

Fast answers need visual help. Please read the yellow banner at the top of this page on how to attach a file and a mocked up solution.

[kilito]

Thanks Trevor for your quick reply. I did remove the select part and got a different error message. As suggested please find attached the excel file with a sample and vb code enabled.

Thanks again for the help!

[bebo021999]

Like this:
Put this in general module.

Sub arrow() 
ActiveSheet.Shapes("test").Select 
With Selection.ShapeRange.Line 
    If Range("A1") > 0 Then 
        .BeginArrowheadStyle = msoArrowheadNone 
        .EndArrowheadStyle = msoArrowheadTriangle 
    Else 
        .BeginArrowheadStyle = msoArrowheadTriangle 
        .EndArrowheadStyle = msoArrowheadNone 
    End If 
End With 
End Sub  

Or, if you want to trigger change (manual input) in cell A1:
put this code in worksheet module.
Change value in A1 to see arrow direction change.

Private Sub Worksheet_Change(ByVal Target As Range) 
If Target.Address(0, 0) <> "A1" Then Exit Sub 
ActiveSheet.Shapes("test").Select 
With Selection.ShapeRange.Line 
    Select Case Target.Value > 0 
        Case True 
            .BeginArrowheadStyle = msoArrowheadNone 
            .EndArrowheadStyle = msoArrowheadTriangle 
        Case Else 
            .BeginArrowheadStyle = msoArrowheadTriangle 
            .EndArrowheadStyle = msoArrowheadNone 
    End Select 
End With 
Range("A1").Select 
End Sub  

[kilito]

Thank you very much for your quick response. I tried you first suggestion and it worked like a charm. So I created 2 more shapes and worked on the code to see if my macro will work. As I mentioned in the beginning I am not expert in vba but I was able to make it work :-) but I think my code is too long or maybe this is the only way to do it. The cells in the future will change automatically and at the end I will have seven shape line with arrows. Here is the code below that I tested on three shapes and it worked:
Sub arrow()

ActiveSheet.Shapes("test").Select
With Selection.ShapeRange.Line
If Range("A1") > 0 Then
.BeginArrowheadStyle = msoArrowheadNone
.EndArrowheadStyle = msoArrowheadTriangle
Else
.BeginArrowheadStyle = msoArrowheadTriangle
.EndArrowheadStyle = msoArrowheadNone
End If

ActiveSheet.Shapes("test2").Select
With Selection.ShapeRange.Line
If Range("A2") > 0 Then
.BeginArrowheadStyle = msoArrowheadNone
.EndArrowheadStyle = msoArrowheadTriangle
Else
.BeginArrowheadStyle = msoArrowheadTriangle
.EndArrowheadStyle = msoArrowheadNone
End If

ActiveSheet.Shapes("test3").Select
With Selection.ShapeRange.Line
If Range("A3") > 0 Then
.BeginArrowheadStyle = msoArrowheadNone
.EndArrowheadStyle = msoArrowheadTriangle
Else
.BeginArrowheadStyle = msoArrowheadTriangle
.EndArrowheadStyle = msoArrowheadNone
End If
End With
End With
End With
End Sub

I have also attached the excel file sample. I broke my work in half to be able to achieve what I am looking for. First is arrow direction base on cell value and after that I will tackle the width size of the arrow based on cell value.

Thanks again for the help.

[bebo021999]

working with "n" arrows, like this:
List arrow's name into array
arrowName = Array("test", "test2", "test3")
then loop through each arrow:

Sub arrow() 
Dim i&, arrowName 
arrowName = Array("test", "test2", "test3") 
For i = 1 To 3 
    ActiveSheet.Shapes(arrowName(i - 1)).Select 
    With Selection.ShapeRange.Line 
        Select Case Cells(i, 1) < 0 
            Case True 
                .BeginArrowheadStyle = msoArrowheadTriangle 
                .EndArrowheadStyle = msoArrowheadNone 
            Case Else 
                .BeginArrowheadStyle = msoArrowheadNone 
                .EndArrowheadStyle = msoArrowheadTriangle 
        End Select 
    End With 
Next 
Range("A1").Select 
End Sub  

[kilito]

Thank you very much for getting back to me so quickly. I will test it tomorrow and keep you posted. I should start reading some VB manual to learn more how to use it :-)

Thanks again

[Andy Pope]

You could create a UDF to which you pass the shape name and value.

in a cell use
=ARROWHEAD("Test",A1)

Please Login or Register  to view this content.

[sintek]

Please Login or Register  to view this content.

[kilito]

Thank you everyone for your suggestions. I am using bebo021999 code, it worked very well on my test. However, when I tried to apply same coding on the shapes I have over a map picture, I don't see the changes in the arrow direction when I change the values of the cells and run the macro. I am wondering if the fact that I grouped all the shapes with the pictures would affect the results?

Any thoughts?

Below is the code I used:

Sub arrow()
Dim i&, arrowName
arrowName = Array("shape1", "shape2", "shape3",”shape4”,”shape5”,”shape6”,”shape7”)
For i = 1 To 7
ActiveSheet.Shapes(arrowName(i - 1)).Select
With Selection.ShapeRange.Line
Select Case Cells(i, 1) < 0
Case True
.BeginArrowheadStyle = msoArrowheadTriangle
.EndArrowheadStyle = msoArrowheadNone
Case Else
.BeginArrowheadStyle = msoArrowheadNone
.EndArrowheadStyle = msoArrowheadTriangle
End Select
End With
Next
Range("AC7").Select
End Sub

I have 7 shapes and values in the cells range from AC7 to AI7. Shape1 arrow direction would be affected by the value changing in AC7, shape2 arrow direction would be affected by the value changing in AD7, etc.

Thanks

[sintek]

cells range from AC7 to AI7

This should work...Even if grouped...

Please Login or Register  to view this content.

Look at your quotation marks ... variations are inconsistent

Please Login or Register  to view this content.

[kilito]

Thank you very much Sintek. I tried your code, in the beginning one of the shapes was behaving in the opposite direction. So I deleted the shape and redrew another one (I guess when you draw the shape, the start and ending of your shape is important). After that it worked when all my cells are positives the arrows are going into my location and when the numbers are negatives the arrows are going out to the opposite direction. Now I will work on how to increase the width of those shapes base on cell values or intervals and will share what I did.

Thanks a lot.

[kilito]

Hi Sintek,
Thanks for your help, your code works now smoothly on all my shapes, I created a button and associated the macro to it. When my numbers changes, I just click on the button to adjust the direction of the arrows based on the cell value. Is there a possibility to make the code run automatically when I open the spreadsheet without having to click on a button?

Regarding changing the width points (thickness) of those arrows based on the same values, it is more difficult that I thought because the width of each arrow has to take in consideration the width of the other arrow shapes simultaneously.
I cannot use the same concept of <0 or >0 and cannot use intervals neither. If I use intervals for example:
if the value is between 0 to 50 then the width (thickness) of the arrow should be 5 for example, the issue here is that you will have 2 arrows with the same width (thickness) of 5 points even the values of the cells are different, like one with 20 as a value and one with 35 as value.
My plan is:
I have 7 shapes and 7 cells range AC7 to AI7 with values as: 41, 248, 74, 156, 19, 829, 205
the width of all the shapes changes based on those values (those values will change automatically with time).
Based on the above example (on the current numbers), the width of shape 6 would be a 10 for example, shape 2 would have something close to 3, shape 7 would be 2.75 or 2.5, then shape 4 would be 2, etc.
Not sure if it is feasible in vba. Right now I change the width (thickness) of those shapes manually by approximatively assigning a number that would make sense visually.

Any feedback would be appreciated.

Thanks

[bebo021999]

I am back.
wake the sub "arrow" up when either:
- sheet active
- manual change value in range AC7:AI7
- click button that sub "arrow" assigned

Try:

Option Explicit 
Private Sub Worksheet_Activate() 
arrow 
End Sub 
Private Sub Worksheet_Change(ByVal Target As Range) 
If Intersect(Target, Range("AC7:AI7")) Is Nothing Then Exit Sub 
arrow 
End Sub 
 
Sub arrow() 
Dim i&, arrowName, rng, wid As Double 
arrowName = Array("shape1", "shape2", "shape3", "shape4", "shape5", "shape6", "shape7") 
rng = Range("AC7:AI7").Value 
For i = 1 To UBound(rng, 2) 
    ActiveSheet.Shapes(arrowName(i - 1)).Select 
    wid = WorksheetFunction.RoundUp(Abs(rng(1, i)) / 100, 0) 
    With Selection.ShapeRange.Line 
        .Weight = wid 
        Select Case rng(1, i) < 0 
            Case True 
                .BeginArrowheadStyle = msoArrowheadTriangle 
                .EndArrowheadStyle = msoArrowheadNone 
            Case Else 
                .BeginArrowheadStyle = msoArrowheadNone 
                .EndArrowheadStyle = msoArrowheadTriangle 
        End Select 
    End With 
Next 
Range("AC7").Select 
End Sub  

[kilito]

Hi everyone,
I was able to figure out how to change the thickness of the line by looking at Class LineFormat and understood that the LineFormat.Weight property will help me understand how to play with the thickness of the line based on a value. This is the first step :-)
Here is the code simple:
Sub test()
ActiveSheet.Shapes("test").Select
With Selection.ShapeRange.Line
If Range("A1") > 0 Then
.Weight = 10
Else
.Weight = 2
End If
End With
End Sub

This code deals with only one shape and the solution is simple because if my value is positive I guess a specific thickness and if negative I get another thickness. I will try to replicate the work on 7 shapes and share what I accomplished first.

Thanks

[kilito]

Thanks bebo021999 for your suggestion. I will look at it and get back to you.

[kilito]

Hi bebo021999, I looked at the code and it is combining both elements I am looking for: arrow direction + the thickness of the arrow. The increment is one point width per 100 value. if I have 2 values with identical value, the width will be identical and that's fine but if I have for example one value is 201 and the other one is 300 their thickness will be identical at 3 point. What I had in mind and again not sure if it is feasible, a code that will dynamically look at my range and assign thicknesses that will take in consideration all the value simultaneously. Means if I have 7 values, in the example above the shape linked to the value 300 should be thicker than the shape with value 201, etc.

I will learn few things from your code and try to adapt to what I have already and post it.

Thanks lot for working on the sample and sharing the code.

[bebo021999]

You can use a lookup table to set a range of value to range of ppt
For example: AK3:AL10 with 1st column is value, 2nd column is ppt
See attachment.

[sintek]

If Range("A1") > 0 Then
.Weight = 10
Else
.Weight = 2
End If

If above is request then below snippet needs to be added to code in post 11...

Please Login or Register  to view this content.

otherwise, if you want individual thicknesses per individual value then bebo table suggestion is way to go

[kilito]

Thank you bebo021999 and Sintek for your feedbacks. I will work on it this morning and keep you posted.

[kilito]

Hi bebo021999 and Sintek,

I combined both vb codes and it worked:

Option Explicit
Private Sub Worksheet_Activate()
arrow
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("AC7:AI7")) Is Nothing Then Exit Sub
arrow
End Sub

Sub arrow()
Dim i&, arrowName, rng, wid As Double
arrowName = Array("shape1", "shape2", "shape3", "shape4", "shape5", "shape6", "shape7")
rng = Range("AC7:AI7").Value
For i = 1 To UBound(rng, 2)
ActiveSheet.Shapes(arrowName(i - 1)).Select
wid = WorksheetFunction.VLookup(Abs(rng(1, i)), Range("AK3:AL10"), 2)
With Selection.ShapeRange.Line
.Weight = wid
.BeginArrowheadStyle = IIf(Cells(7, i + 28) > 0, 2, 1)
.EndArrowheadStyle = IIf(Cells(7, i + 28) > 0, 1, 2)
End With
Next
Range("AC7").Select
End Sub

The code is awesome but still doesn't answer completely what I am looking for. The arrow direction portion is perfect, and the thickness based on lookup table is also working but it doesn't take into consideration the fact if I have 2 or 3 values above 500 value, they will all have width ppt of 15. Therefore you cannot visually make a difference between 3 values for example: 500, 1000 and 1500 because their thickness will look identical.
Is there a possibility to modify the above code with a function that will look at range AC7 to AI7 (the numbers will be absolute when it comes to the thickness) and compare those value to make sure the thickness will automatically be chosen based on the comparison of all values.
I am attaching the file I worked with and let me explain what I am trying to accomplish:

The file contains:
AC=50, AD=800, AE=-75, AF=150, AG=-500, AH=200, AI=1500 in this case the thickness of AD, AG and AI is identical. What I would like to achieve in terms of thickness is: AI thicker than AD thicker than AG thinker than AH thicker than AF... etc.

Knowing that the range from AC to AI will always have different numbers at some point of time.

I also figured out the ppt width I would like to have for the seven shapes from the smaller value to the highest value: ppt: 1, 2, 3.25, 4.75, 6.25, 8 and 10.

It means that for our example: AC should have a thickness of 1 ppt, AE should have 2, AF should have 3.25, AH should have 4.75…. etc.

Thank you very much for your assistance with this.

Please note, I am working on a solution: in the vlookup table in the first column I will put ranking from 1 to 7 and in the second column I will put the ppt desired ones, now trying to come with a function to rank values from AC to AI and include it inside the code. I will share what I am doing as soon as I am done.

[kilito]

Hi bebo021999 and Sintek,

I came up with a solution that works, using Sort, Abs and Transpose function in the vlookup table. I am sharing the file please take a look at the code and tell me if it can be streamlined or if it is perfect as it is. Because since the function in the range (AK3:AK9) already takes care of the ABS part, is this still necessary (the bold part) to have the following line as is:
wid = WorksheetFunction.VLookup(Abs(rng(1, i)), Range("AK3:AL9"), 2)

How can I make the attached macro running automatically when I open the file?

Thanks a lot for your help, I learned few tricks :-)

[kilito]

Hello again,

I figured out how to run the macro automatically when i open the file, he is the code below:

Private Sub Workbook_Open()

Dim i&, arrowName, rng, wid As Double
arrowName = Array("shape1", "shape2", "shape3", "shape4", "shape5", "shape6", "shape7")
rng = Range("AC7:AI7").Value
For i = 1 To UBound(rng, 2)
ActiveSheet.Shapes(arrowName(i - 1)).Select
wid = WorksheetFunction.VLookup(Abs(rng(1, i)), Range("AK3:AL9"), 2)
With Selection.ShapeRange.Line
.Weight = wid
.BeginArrowheadStyle = IIf(Cells(7, i + 28) > 0, 2, 1)
.EndArrowheadStyle = IIf(Cells(7, i + 28) > 0, 1, 2)
End With
Next
Range("AC7").Select
End Sub

What do you think of the code?

Thanks

[jolivanes]

Would it not be easier to use an arrow (UpArrow, DownArrow etc)?

[kilito]

Hi Jolivanes,

Thanks for the feedback, the arrows are curves and the direction of the arrows mainly showing people coming in and people coming out, the shapes are above a map picture. For now it works fine, just trying to tweak the code and see if the line with absolute range is necessary or not.

Thanks

[sintek]

Please Login or Register  to view this content.

[kilito]

Hi Sintek,

Thank you for your reply. Your code is much smaller :-) I will try it on Monday and get back to you.

Cheers

[kilito]

Hi Guys,

Sorry for the late reply, I was sick last week. I did try Sintek code but it is not behaving properly when it comes to the thickness of the arrows. Below is the code that works perfectly no matter what the values are:

Private Sub Workbook_Open()
Dim i&, arrowName, rng, wid As Double
arrowName = Array("shape1", "shape2", "shape3", "shape4", "shape5", "shape6", "shape7")
rng = Range("AC4:AI4").Value
For i = 1 To UBound(rng, 2)
ActiveSheet.Shapes(arrowName(i - 1)).Select
wid = WorksheetFunction.VLookup(Abs(rng(1, i)), Range("AK3:AL9"), 2)
With Selection.ShapeRange.Line
.Weight = wid
.BeginArrowheadStyle = IIf(Cells(4, i + 28) > 0, 2, 1)
.EndArrowheadStyle = IIf(Cells(4, i + 28) > 0, 1, 2)
End With
Next
Range("AC4").Select

End Sub

Thanks all for your help!

Cheers.

[kilito]

Hi again,

I just realized that the macro will not work properly if I have different tabs in my excel sheet (especially if when opening the file it is not the sheet with the map that is active first) , I get this error: runtime error the item with the specified name wasn't found excel.

So I added a line and modified the "select" line as below:

Private Sub Workbook_Open()
Dim i&, arrowName, rng, wid As Double
arrowName = Array("shape1", "shape2", "shape3", "shape4", "shape5", "shape6", "shape7")
rng = Range("AC4:AI4").Value
For i = 1 To UBound(rng, 2)
Worksheets(3).Activate
Worksheets(3).Shapes(arrowName(i - 1)).Select
wid = WorksheetFunction.VLookup(Abs(rng(1, i)), Range("AK3:AL9"), 2)
With Selection.ShapeRange.Line
.Weight = wid
.BeginArrowheadStyle = IIf(Cells(4, i + 28) > 0, 2, 1)
.EndArrowheadStyle = IIf(Cells(4, i + 28) > 0, 1, 2)
End With
Next
Range("AC4").Select

End Sub

Now I am getting this error: "Unable to get the VLookup property of the WorksheetFunction Class"

So how to fix my code so it will run automatically, knowing that I have 4 tabs: the first tab I have a macro button for a graph, the 4th tab I have a macro for another graph. While the main macro that handle arrow direction and thickness is in the 3rd tab (Macro is saved under ThisWorkbook) and using Workbook open feature to be launched automatically.

Thank

[kilito]

Hi everyone,

It took me awhile but I finally found a solution to my problem :-), here is the code below:

Private Sub Workbook_Open()
Worksheets("Pop3").Activate
Dim i&, arrowName, rng, wid As Double
arrowName = Array("shape1", "shape2", "shape3", "shape4", "shape5", "shape6", "shape7")
rng = Range("AC4:AI4").Value
For i = 1 To UBound(rng, 2)
ActiveSheet.Shapes(arrowName(i - 1)).Select
wid = WorksheetFunction.VLookup(Abs(rng(1, i)), Range("AK3:AL9"), 2)
With Selection.ShapeRange.Line
.Weight = wid
.BeginArrowheadStyle = IIf(Cells(4, i + 28) > 0, 2, 1)
.EndArrowheadStyle = IIf(Cells(4, i + 28) > 0, 1, 2)
End With
Next
Range("AC4").Select

End Sub

Now no matter how I save the excel file (let's say I am in the first tab), when I reopen my excel file, it takes me directly to the 3rd tab and run the code smoothly.

Thanks