AutoShapes VBA Macro

[Jdax57]

I'm trying to find a way to create a Macro in Excel 2007 that creates/formats an existin AutoShape Arrow (msoShapeUpArrow) With the following properties (H: 0.13" W:0.49") With the rotation being flexible dependent on a cardinal direction (meaning If the spreadsheet shows South it would equate the arrow pointing to 180 Degrees).

Example:

Day 1 Winds from NW (ARROW 1 pointing to 125 in Cell E23)
Day 2 Winds from W (ARROW 2 pointing to 090 in cell M23)
Day 3 Winds from SW (ARROW 3 pointing to 045 in cell U23)
Day 4 Winds from N (ARROW 4 pointing to 180 in Cell AC23)
Day 5 Winds from NW (ARROW 5 pointing to 125 in Cell AK23)

And if wind direction is VRB the ARROW would be hidden or deleted.

I can reference the wind direction conversion to another block and pull the converted heading to be used in the macro to determind the direction of the arrow. Can anyone help me with this?

Thanks!

Alex

 

[Gary McMaster]

I don't understand what you mean by "the spreadsheet shows South". I hope the sample below will at least get you started. It will create an arrow on the active sheet and then cause that arrow to rotate by the amount specified in cells A1 thru A25 when the user clicks on one of those cells. It does not test for numeric values and will crash if it encounters a non-numeric value in A1:A25

Gary

Public Sub CreateArrow()

'Run this procedure once to create & name the arrow

Dim oShape As Shape
Dim oActive As Worksheet
Dim oArrowCell As Range

Set oActive = ActiveSheet 'Enable intellisense

'Delete the arrow if it already exists
For Each oShape In oActive.Shapes
    If oShape.Name = "WindDirArrow" Then oShape.Delete
Next

'Set desired origin cell
Set oArrowCell = oActive.Range("D12")

'Create a new arrow
Set oShape = oActive.Shapes.AddShape(msoShapeUpArrow, oArrowCell.Left, oArrowCell.Top, 15, 50)

'Name the arrow for easy ID
oShape.Name = "WindDirArrow"

With oShape
    'Left, Top, Width, Height  & Rotation, unnecessary, same as insertion size above
    .Left = oArrowCell.Left
    .Top = oArrowCell.Top
    .Width = 15
    .Height = 50
    .Rotation = 45
    '.Whatever else
End With

End Sub


Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)

'Fill cells "A1" thru "A25" with number series (step 15) 0 thru 360 degrees
'When user selects cell in range "A1:A25" rotate arrow to position indicated by cell value

Dim oShape As Shape
Dim oIsIntersect As Range

Set oIsIntersect = Application.Intersect(Target, Range("A1:A25"))

If Not oIsIntersect Is Nothing Then

    For Each oShape In Sh.Shapes
        If oShape.Name = "WindDirArrow" Then Exit For
    Next

    If Not oShape Is Nothing Then
        'Should test for numeric value in cell
        oShape.Rotation = Target.Value
    End If

End If

End Sub

 

[Jdax57]

Gary thanks for the help I haven't tested the code yet. I will as soon as I get to work. What I meant by "the spreadsheet shows south" meant that if I entered the word "South" or "S" in Cell A1 it gets converted to a numeric value of 180 (as south is a heading of 180 degrees)...Like a compass rose. I'll take a look at the code and see if I can customize it to fit. If not I'll be asking for help again...

Alex

 

[Gary McMaster]

If you plan on using text then maybe "Select Case" would be appropriate.

Gary

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)

'Fill cells "A1" thru "A8" with text representing compass points (see case statements below)
'When user selects cell in range "A1:A8" rotate arrow to position indicated by cell text value

Dim oShape As Shape
Dim oIsIntersect As Range

Set oIsIntersect = Application.Intersect(Target, Range("A1:A8"))

If Not oIsIntersect Is Nothing Then

    For Each oShape In Sh.Shapes
        If oShape.Name = "WindDirArrow" Then Exit For
    Next

    If oShape Is Nothing Then Exit Sub

    Select Case UCase(Target.Value)
        
        Case "N", "NO", "NORTH"
            oShape.Rotation = 0
            
        Case "NE", "N EAST", "NO EAST", "NORTH EAST", "NORTHEAST"
            oShape.Rotation = 45
            
        Case "E", "EA", "EAST"
            oShape.Rotation = 90
            
        'case southeast
            
        Case "S", "SO", "SOUTH"
            oShape.Rotation = 180
            
        'case southwest
            
        Case "W", "WE", "WEST"
            oShape.Rotation = 270
            
        'case northwest

        Case Else
            oShape.Rotation = 0
            
    End Select

End If

End Sub

 

[Jdax57]

Gary,
The following code is one I'm looking for:

Public Sub CreateArrow()

'Run this procedure once to create & name the arrow

Dim oShape As Shape
Dim oActive As Worksheet
Dim oArrowCell As Range

Set oActive = ActiveSheet 'Enable intellisense


'Delete the arrow if it already exists
For Each oShape In oActive.Shapes
If oShape.Name = "WindDirArrow" Then oShape.Delete
Next

'Set desired origin cell
Set oArrowCell = oActive.Range("D12")

'Create a new arrow
Set oShape = oActive.Shapes.AddShape(msoShapeUpArrow, oArrowCell.Left, oArrowCell.Top, 15, 50)

'Name the arrow for easy ID
oShape.Name = "WindDirArrow"

With oShape
'Left, Top, Width, Height & Rotation, unnecessary, same as insertion size above
.Left = oArrowCell.Left
.Top = oArrowCell.Top
.Width = 15
.Height = 50
.Rotation = 360
'.Whatever else
End With

End Sub

Question is how can I pull the rotation from say Cell A2?

Say in Cell A1 I have N(north) typed in I can do a Vlookup and pull up the value for as 360 in Cell A2. And then run the macro listed above and create an arrow in cell D12 with an arrow pointing north(360). I like the code above I appreciate your help!

Alex

 

[Gary McMaster]

Say in Cell A1 I have N(north) typed in I can do a Vlookup and pull up the value for as 360 in Cell A2. And then run the macro listed above and create an arrow in cell D12 with an arrow pointing north(360).

That's basically what the other half in the Worksheet_SheetSelectionChange event does. You could change the cell addresses and get the rotation value from any cell you want.

Maybe you could use the cell double click event instead. Take the value of the double clicked cell or an offset from the double clicked cell.

Gary

 

[Jdax57]

Actually I figured it out Gary! Thanks!!

Using oRot as a Long Val and pulling the value from the cell in question and setting it at the end..

Thanks for your help!

Alex



Public Sub CreateArrow1()

'Run this procedure once to create & name the arrow

Dim oShape As Shape
Dim oActive As Worksheet
Dim oArrowCell As Range
Dim oRot As Long


Set oActive = ActiveSheet 'Enable intellisense

oRot = Range("BE16").Value

'Delete the arrow if it already exists
For Each oShape In oActive.Shapes
If oShape.Name = "WindDirArrow1" Then oShape.Delete
Next

'Set desired origin cell
Set oArrowCell = oActive.Range("E22")

'Create a new arrow
Set oShape = oActive.Shapes.AddShape(msoShapeUpArrow, oArrowCell.Left, oArrowCell.Top, 15, 50)

'Name the arrow for easy ID
oShape.Name = "WindDirArrow1"

With oShape
'Left, Top, Width, Height & Rotation, unnecessary, same as insertion size above
.Left = oArrowCell.Left
.Top = oArrowCell.Top
.Width = 12
.Height = 41
.Fill.ForeColor.RGB = RGB(0, 0, 0)
.Line.ForeColor.RGB = RGB(0, 0, 0)
.Rotation = oRot

'.Whatever else
End With

End Sub

 

[Jdax57]

Question though

With the code above,

I need to add one more thing.

Since oRot= The value of Cell BE16 (Say it's 180)
it creates an arrow with a rotation of 180.

But if Cell Value BE 16 is NONE
How do I set the macro to NOT create a new arrow, but rather delete the old arrow?

Thanks.

Alex

 

[Gary McMaster]

Alex,

Once you determine you don't need the shape you can delete with:

ActiveSheet.Shapes("WindDirArrow").Delete

Of course you must have the correct name. I noticed that I had the number 1 stuck on the end of the name in the code. That's something I used for a quick test (name not found) and should not have been there. The name should be the same everywhere in the code.

You can use "If Then" or "Select Case" or whatever logic you need to determine when to delete it.

The original code I provided, "CreateArrow" procedure, actually deletes it (if it exists) and then recreates it. Excel throws some nasty errors if you try to duplicate a shape name.

Gary

 

[Gary McMaster]

Maybe it would be better to just hide the shape rather than delete it if your not really done with it. If you hide it you'll only have to deal with creating it or checking for its existence once.

ActiveSheet.Shapes("WindDirArrow").Visible = msoFalse
ActiveSheet.Shapes("WindDirArrow").Visible = msoTrue

Gary