directional arrow excel

I have a column of directional data and wondering if there is any way to illustrate a direction from either the 0-360 degree or N      NNE       NE      ENE      E      ESE      SE      SSE      S      SSW       SW      WSW      W      WNW      NW      NNW  designation formats as an arrow graphic in excel 2010?
PVR101Asked:
Who is Participating?

[Product update] Infrastructure Analysis Tool is now available with Business Accounts.Learn More

x
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

Rob HensonFinance AnalystCommented:
There is a set of conditional formatting icons that can do N through NE, E, SE and S but can't see a way to do the other side of the compass.

I will keep looking.

Thanks
Rob H
Rob HensonFinance AnalystCommented:
Wingdings font has a set of arrows for all 8 directions. You can convert your degree number or directional letter to the symbol code with a lookup and then format with Wingdings font.

See attached.

Rob H
Directional-arrows.xlsx
PVR101Author Commented:
thanks Rob - a pitty not as easy as applying conditional formatting. - see sample sheet.

 Maybe it requires some sort of a macro  - found this on web but not sure how to modify or if fits needs..  

Sub Demo()
Dim angle

[A1] = Chr(223)
[A1].Font.Name = "Wingdings"

With Range("A1")
For angle = -90 To 90 Step 1
.HorizontalAlignment = xlCenter
.Orientation = angle
Next
[A1] = Chr(224)
For angle = -90 To 90 Step 1
.HorizontalAlignment = xlCenter
.Orientation = angle
Next
End With
End Sub
dir-sample.xlsx
Exploring ASP.NET Core: Fundamentals

Learn to build web apps and services, IoT apps, and mobile backends by covering the fundamentals of ASP.NET Core and  exploring the core foundations for app libraries.

Danny ChildIT ManagerCommented:
Could you combine 2 arrows to show the final outcome?  would that be acceptable?
M--Personal-ee-compass.png
Saqib Husain, SyedEngineerCommented:
Try this macro

Sub directions()
    Dim ws As Worksheet
    Dim shp As Shape
    Dim cel As Range
    Dim ang As Double
    Dim cx As Single
    Dim cy As Single
    Dim r As Single
    Dim ns As Shape
    Set ws = ActiveSheet
    For Each shp In ws.Shapes
        shp.Delete
    Next shp
    For Each cel In Range("a1:A" & Range("A" & Rows.Count).End(xlUp).Row)
        If cel <> "" And cel <> "NaN" Then
            ang = (cel - 90) / 180 * WorksheetFunction.Pi()
            cx = cel.Offset(, 2).Left + cel.Offset(, 2).Width / 2
            cy = cel.Top + cel.Height / 2
            r = cel.Height / 2 - 1
            Set ns = ws.Shapes.AddLine(r * Cos(ang) + cx, r * Sin(ang) + cy, -r * Cos(ang) + cx, -r * Sin(ang) + cy)
            Set ns = ws.Shapes.AddLine(r * Cos(ang) + cx, r * Sin(ang) + cy, r / 4 * Cos(ang + 0.6) + cx, r / 4 * Sin(ang + 0.6) + cy)
            Set ns = ws.Shapes.AddLine(r * Cos(ang) + cx, r * Sin(ang) + cy, r / 4 * Cos(ang - 0.6) + cx, r / 4 * Sin(ang - 0.6) + cy)
        End If
    Next cel

End Sub
Danny ChildIT ManagerCommented:
version using 2 arrows and vlookups.  Just for fun, I kept the vlookup table down to the minimum 8 directions, and then parsed out the relevant characters from the input.

Looking back, it's probably more complex than it needs to be, but hey, I needed the exercise.
M--Personal-ee---compass-v3.xlsx
PVR101Author Commented:
Rob – thanks again however really looking for solution for full 360 deg compass and 16 directions.

Danch99 – nice approach but want single arrow graphic and compass spectrum. Can it be modified for 16 directions?

Syed – macro on sample sheet works great when applied although still trying to understand coding and apply to actual workbook.  I have failed in my attempts so far to modify where similar column data are actually in columns E and F respectively (as opposed to A and B) and where columns D and G are populated with other data – therefore how do I modify the coding so it will work correctly and inputs arrows in new column inserted column between F and G?

Is it possible to modify the arrow thickness/seize /colour etc  how might this be done ?
PVR101Author Commented:
Syed, further to above reply queries i have attempted to amend the code for actual workbook where have headings row 1 and want to input arrows in column 15.  similar data is actually in column E and F with D and G populated with data .

Sub directions()
    Dim ws As Worksheet
    Dim shp As Shape
    Dim cel As Range
    Dim ang As Double
    Dim cx As Single
    Dim cy As Single
    Dim r As Single
    Dim ns As Shape
    Set ws = ActiveSheet
    For Each shp In ws.Shapes
        shp.Delete
    Next shp
    For Each cel In Range("e2:E" & Range("E" & Rows.Count).End(xlUp).Row)
        If cel <> "" And cel <> "NaN" Then
            ang = (cel - 90) / 180 * WorksheetFunction.pi()
            cx = cel.Offset(, 15).Left + cel.Offset(, 15).Width / 2
            cy = cel.Top + cel.Height / 2
            r = cel.Height / 2 - 1
            Set ns = ws.Shapes.AddLine(r * Cos(ang) + cx, r * Sin(ang) + cy, -r * Cos(ang) + cx, -r * Sin(ang) + cy)
            Set ns = ws.Shapes.AddLine(r * Cos(ang) + cx, r * Sin(ang) + cy, r / 4 * Cos(ang + 0.6) + cx, r / 4 * Sin(ang + 0.6) + cy)
            Set ns = ws.Shapes.AddLine(r * Cos(ang) + cx, r * Sin(ang) + cy, r / 4 * Cos(ang - 0.6) + cx, r / 4 * Sin(ang - 0.6) + cy)
        End If
    Next cel

End Sub


how can i correct as suspect error due to row 1?

also what might the code look like if want to convert a specific cell deg value or compass heading to an arrow?

finally if wish to convert a row of compass headings or degrees say Y3:AN3 in a sheet?

Thank you
Saqib Husain, SyedEngineerCommented:
Here are revised macros with improved arrows.

The first one will work as before deleting all arrows and recreating all.
The second one will look at the selected cells and delete arrows in those rows and recreate them.

Sub directionsall()
    Dim ws As Worksheet
    Dim shp As Shape
    Dim cel As Range
    Set ws = ActiveSheet
    For Each shp In ws.Shapes
        shp.Delete
    Next shp
    
    For Each cel In Range("e2:E" & Range("E" & Rows.Count).End(xlUp).Row)
        If cel <> "" And cel <> "NaN" Then
            Call drawarrow(ws, cel)
        End If
    Next cel
End Sub
Sub directionssel()
    Dim ws As Worksheet
    Dim shp As Shape
    Dim cel As Range
    Set ws = ActiveSheet
    
    For Each cel In Intersect(Selection.EntireRow, Range("E:E")).Cells
        For Each shp In ws.Shapes
        If cel.Row = shp.TopLeftCell.Row Then
            shp.Delete
        End If
        Next shp
        If cel <> "" And cel <> "NaN" Then
            Call drawarrow(ws, cel)
        End If
    Next cel
End Sub

Sub drawarrow(ws, cel As Range)
    Dim ang As Double
    Dim cx As Single
    Dim cy As Single
    Dim r As Single
    Dim ns As Shape
    ang = (cel - 90) / 180 * WorksheetFunction.Pi()
    cx = cel.Offset(, 15).Left + cel.Offset(, 15).Width / 2
    cy = cel.Top + cel.Height / 2
    r = cel.Height / 2 - 1
    Set ns = ws.Shapes.AddConnector(msoConnectorStraight, -r * Cos(ang) + cx, -r * Sin(ang) + cy, r * Cos(ang) + cx, r * Sin(ang) + cy)
    ns.Line.EndArrowheadStyle = msoArrowheadOpen
    ns.Line.EndArrowheadLength = msoArrowheadShort
    ns.Line.EndArrowheadWidth = msoArrowheadNarrow
    ns.Line.Weight = 2
End Sub

Open in new window

PVR101Author Commented:
Thanks Syed - sorry if not clear above but for the select cell code how can i modify so able to select any cell or cell range on any sheet and convert to arrow from either a degree compass reading  or text direction?

Given over 8500 rows unfortuently the ALL code takes quite a while to run on PC and makes file size very large.  How can I select cells and remove  arrows quickly as currently need select individual icon and delete as selecting cell and pressing delete does not remove.
Saqib Husain, SyedEngineerCommented:
I am not clear on what you want. Can you tell me what happens when you run the given code and how does it differ from what you want it to do?
PVR101Author Commented:
code runs and creates arrows for given direction in column E and outputs on column 15  - all OK (just long time to process due to number of data rows

However I am also looking to see if able to select a single cell  on a sheet  - not just in E column as current code allows for but in any sheet in workbook or a range of cells eg Y3:AN3 on separate sheet and create arrow based on either there compass direction or direction text (16 directions) contents

lastley after creating arrows for full column E on workbook the file size has more than doubled in size - the only apparent way to delete arrows after creating them is to select the idividual arrow icons and delete one at a time so need a way to delete if required.

hope that helps clarify some ?
Saqib Husain, SyedEngineerCommented:
... select a single cell  on a sheet ...... or a range of cells eg Y3:AN3 ...
Where do you want to place the arrows for these?

To delete selected arrows, select the cells and run this macro
Sub deletesel()
    Dim ws As Worksheet
    Dim shp As Shape
    Dim cel As Range
    Set ws = ActiveSheet
    
    For Each cel In Selection.Cells
        For Each shp In ws.Shapes
            If cel.Address = shp.TopLeftCell.Address Then
                shp.Delete
            End If
        Next shp
    Next cel
End Sub

Open in new window

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
PVR101Author Commented:
Hi Syed,
It would be really helpful if can code for output 1 cell above row selection - for single cell if able to illustrate code for output 1 cell above and 1 cell to right so able to understand and maybe modify if required going forward.

I applied del code to sheet and ran - excel crashes/hangs - (not responding) status error, so tested using  just a single cell  - it gave same error but after over 2 mins it did actually delete the icon so maybe just a function of number of cells to delete and PC spec  - will try let run over night for column.
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Excel

From novice to tech pro — start learning today.