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:="Worksheet"
Sheets(Sheets.Count).Name = "Rose"
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 " drawing "; lastarrowdir; "degrees"
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 " b & w = "; 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 = """" & lastv & " - ""0"
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 = "N"
.Font.Name = "Monotype Corsiva"
.Font.FontStyle = "Bold"
.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 = "E"
.Font.Name = "Monotype Corsiva"
.Font.FontStyle = "Bold"
.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 = "S"
.Font.Name = "Monotype Corsiva"
.Font.FontStyle = "Bold"
.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 = "W"
.Font.Name = "Monotype Corsiva"
.Font.FontStyle = "Bold"
.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, "0.0"
.Font.Name = "arial"
.Font.FontStyle = "Bold"
.Font.Size = c
End With
End If
Next
ActiveSheet.Shapes.SelectAll
Selection.ShapeRange.Group.Select
End Sub
'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:="Worksheet"
Sheets(Sheets.Count).Name = "Rose"
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 " drawing "; lastarrowdir; "degrees"
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 " b & w = "; 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 = """" & lastv & " - ""0"
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 = "N"
.Font.Name = "Monotype Corsiva"
.Font.FontStyle = "Bold"
.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 = "E"
.Font.Name = "Monotype Corsiva"
.Font.FontStyle = "Bold"
.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 = "S"
.Font.Name = "Monotype Corsiva"
.Font.FontStyle = "Bold"
.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 = "W"
.Font.Name = "Monotype Corsiva"
.Font.FontStyle = "Bold"
.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, "0.0"
.Font.Name = "arial"
.Font.FontStyle = "Bold"
.Font.Size = c
End With
End If
Next
ActiveSheet.Shapes.SelectAll
Selection.ShapeRange.Group.Select
End Sub