Wind Rose

Ever need a wind rose? Here's a start:

'This routine inserts a new worksheet and draws a series of shapes to create
'a basic wind rose, which is a figure showing wind direction, frequency, and speed.

'Input data has the form:
' 1 4 6 ...
' 2 0.01% 0.01% 0.00% ...
' 5 0.20% 0.17% 0.19% ...
'10 0.51% 0.47% 0.48% ...
'Where line 1 is wind direction in degrees and column 1 is a list
'of wind speeds. The data is percent of time wind blows from given
'direction.
'In C3 above, the wind blows at 2 - 5 mph from 22 degrees 0.17% of time.
'Selection must include the wind direction and wind speed

Sub Windrose()
'
Dim color(2, 9) As Integer

dirct = Selection.Columns.Count - 1
SpdCt = Selection.Rows.Count - 1
FRow = Selection.Row + 1
FCol = Selection.Column + 1
Pi = 3.1415926
xsize = 600 'approx Max size in x and y
xoff = 500 'offset from left
yoff = 400 'offset from top

'------------------- set number of arrows
arrowwidth = 30 'degrees
'---------------------------------------------

'Wind speeds are indicated by colors but Excel color tables don't match
'cells: 1 black, 2, white, 3 red, 4 green, 5 blue, 6 yellow, 7 purple, 8 lt blue
' 9 dk red, 10 dk green
color(1, 0) = 36 'cells
color(1, 1) = 8
color(1, 2) = 6
color(1, 3) = 4
color(1, 4) = 5
color(1, 5) = 7
color(1, 6) = 3
'shapes: 1 white, 2 red, 3 green, 4 blue, 5 yellow, 6 purple, 7 lt blue, 8 black
' 9 white, 10 red
color(2, 0) = 43 'shapes
color(2, 1) = 7
color(2, 2) = 5
color(2, 3) = 3
color(2, 4) = 4
color(2, 5) = 6
color(2, 6) = 2

'scan for min and max values
mindir = 999
maxdir = -999
maxv = -999
For c = FCol To FCol + dirct - 1
If Cells(FRow - 1, c) < mindir Then mindir = Cells(FRow - 1, c)
If Cells(FRow - 1, c) > maxdir Then maxdir = Cells(FRow - 1, c)
For r = FRow To FRow + SpdCt - 1
If Cells(r, c) > maxv Then maxv = Cells(r, c)
Next
Next

'set plot scale
xscale = xsize / maxv / 3
't = 2 * 3.1415926 / DirCt / 1.25 'angular width of arrows
t = (maxdir - mindir) * arrowwidth / 50000

'draw on a new sheet (convenient for erasing)
Set datasheet = ActiveSheet
Sheets.Add after:=Sheets(Sheets.Count), Type:=&quot;Worksheet&quot;
Sheets(Sheets.Count).Name = &quot;Rose&quot;
Set Rosesheet = Sheets(Sheets.Count)
Rosesheet.Select

'Draw wind rose
If True Then 'a simple on/off switch for debugging
maxarrow = -999 'for scale
lastarrowdir = mindir - arrowwidth
For c = FCol To FCol + dirct - 1
lastv = 0 'for legend
If datasheet.Cells(FRow - 1, c) > lastarrowdir + arrowwidth Then
c = c - 1
lastarrowdir = datasheet.Cells(FRow - 1, c)
Debug.Print &quot; drawing &quot;; lastarrowdir; &quot;degrees&quot;
datasheet.Cells(FRow - 1, c).Font.ColorIndex = 3 '<======= mark which data is used
a = datasheet.Cells(FRow - 1, c) * Pi / 180 - Pi / 2
p = 0
For r = FRow To FRow + SpdCt - 1
p = p + datasheet.Cells(r, c) 'sum percentages if necessary
If p > maxarrow Then maxarrow = p 'track the longest arrow to set scales later
b = xscale * p
w = b * t
Debug.Print &quot; b & w = &quot;; b; w
With Cells(15 + r - FRow, 5) 'add increment to legend
.Formula = datasheet.Cells(r, FCol - 1)
.Interior.ColorIndex = color(1, r - FRow)
.HorizontalAlignment = xlCenter
.NumberFormat = &quot;&quot;&quot;&quot; & lastv & &quot; - &quot;&quot;0&quot;
lastv = Int(Cells(15 + r - FRow, 5))
End With
If b > 10 Then 'draw shape but function jams if b is too small
With ActiveSheet.Shapes.BuildFreeform(msoEditingCorner, xoff, yoff)
.AddNodes msoSegmentLine, msoEditingAuto, _
xoff + b * Cos(a) - w * Sin(a), yoff + b * Sin(a) + w * Cos(a)
.AddNodes msoSegmentLine, msoEditingAuto, _
xoff + b * Cos(a) + w * Sin(a), yoff + b * Sin(a) - w * Cos(a)
.AddNodes msoSegmentLine, msoEditingAuto, xoff, yoff
.ConvertToShape.Select
Selection.ShapeRange.ZOrder msoSendToBack
Selection.ShapeRange.Fill.ForeColor.SchemeColor = color(2, r - FRow)
End With
End If
Next
Else
'could accumlate values to cut out a spreadsheet step
End If
Next
End If

'draw scales
b = maxarrow * xscale * 1.2
c = 15
d = 37.5
ActiveSheet.Shapes.AddLine(xoff, yoff - b, xoff, yoff + b).Select
ActiveSheet.Shapes.AddLine(xoff - b, yoff, xoff + b, yoff).Select

'ActiveSheet.Shapes.AddLine(xoff, yoff - maxarrow * xscale / 2, xoff, yoff + maxarrow * xscale / 2).Select
'ActiveSheet.Shapes.AddLine(xoff - maxarrow * xscale / 2, yoff, xoff + maxarrow * xscale / 2, yoff).Select

ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, xoff - c, yoff - b - c, d, d).Select
'ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, xoff - 10, yoff - a * xscale / 2 - 10, 37.5, 28.5).Select
With Selection
.ShapeRange.Line.Visible = msoFalse
.Characters.Text = &quot;N&quot;
.Font.Name = &quot;Monotype Corsiva&quot;
.Font.FontStyle = &quot;Bold&quot;
.Font.Size = 20
End With
ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, xoff + b - c, yoff - c, d, d).Select
With Selection
.ShapeRange.Line.Visible = msoFalse
.Characters.Text = &quot;E&quot;
.Font.Name = &quot;Monotype Corsiva&quot;
.Font.FontStyle = &quot;Bold&quot;
.Font.Size = 20
End With
ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, xoff - c, yoff + b - c, d, d).Select
With Selection
.ShapeRange.Line.Visible = msoFalse
.Characters.Text = &quot;S&quot;
.Font.Name = &quot;Monotype Corsiva&quot;
.Font.FontStyle = &quot;Bold&quot;
.Font.Size = 20
End With
ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, xoff - b - c, yoff - c, d, d).Select
With Selection
.ShapeRange.Line.Visible = msoFalse
.Characters.Text = &quot;W&quot;
.Font.Name = &quot;Monotype Corsiva&quot;
.Font.FontStyle = &quot;Bold&quot;
.Font.Size = 20
End With

c = 12 'text size
For a = 1 To 8
b = a * xscale / 40
If xoff - b > xoff - (maxarrow * xscale) Then
ActiveSheet.Shapes.AddShape(msoShapeOval, xoff - b, yoff - b, 2 * b, 2 * b).Select
Selection.ShapeRange.Fill.Visible = msoFalse
Selection.ShapeRange.Line.Weight = 1.5
Selection.ShapeRange.Line.DashStyle = msoLineRoundDot
ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, _
xoff - (b / 1.41) - c, yoff - (b / 1.41) - c, 3 * c, 2 * c).Select
With Selection
.ShapeRange.Line.Visible = msoFalse
.ShapeRange.Fill.Visible = msoFalse
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Characters.Text = Format(a * xscale / 600, &quot;0.0&quot
.Font.Name = &quot;arial&quot;
.Font.FontStyle = &quot;Bold&quot;
.Font.Size = c
End With
End If
Next

ActiveSheet.Shapes.SelectAll
Selection.ShapeRange.Group.Select
End Sub

This looks interesting. I have two questions:

1. Where do we get the data to insert into the program to create the Wind Rose?

2. Are there Wind Roses available for specific sites like airports and how would we get copies of them?