Macro converting Wind Direction from text to degrees

[Norm Shea]

My macro skills are not great so I’m hoping someone can help me. I’m
trying to come up with a macro that will convert Wind Direction from
text to degrees in a number of different files. The data typically
starts at N17 and extends down to roughly N26000. Here is the format I
need to create.

N 0
NNE 23
NE 45
ENE 68
E 90
ESE 113
SE 135
SSE 158
S 180
SSW 203
SW 225
WSW 248
W 270
WNW 293
NW 315
NNW 338

Thanks for any assistance anyone can provide.

 

[Helmut Weber]

Hi Norm,

forget about the "MVP" in my signature.
It is for Word, not Excel, which I am only playing with.

I created a testing environment,
an first array which holds the wind direction as text in letters.
("N,NNE,NE,ENE,E,ESE,SE,SSE,S,SSW,SW,WSW,W,WNW,NW,NNW", ",")

A second array which holds the wind direction as text in digits.
("0,23,45,68,90,113,135,158,180,203,225,248,270,293,315,338", ",")

A third array which holds the wind direction as number,
so that e.g. N would correspont to 0,
NNE would correspont to 23 ...

I filled in column 1 the cells from row 17 to 26000
with random text values from:
"N,NNE,NE,ENE,E,ESE,SE,SSE,S,SSW,SW,WSW,W,WNW,NW,NNW"

Then I loop through all cells from 17 to 26000,
check what index in the first array the value of the cell has,
and write the corresponding value from the third array (numbers)
in the cell right next to it.

Needs 15 seconds, here and now.

Yes, a challenge, IMHO, for someone saying

My macro skills are not great

There are a million other ways and many details,
which I can't explain in a posting.

' -------------------------------------------------------------------
Sub Test447()
Dim lTime As Single
lTime = Time
Dim sDrc() As String ' direction
Dim sTmp() As String
Dim lDrc(0 To 15) As Long
Dim lRow As Long
Dim x As Long
sDrc = Split("N,NNE,NE,ENE,E,ESE,SE,SSE,S,SSW,SW,WSW,W,WNW,NW,NNW",
",")
sTmp =
Split("0,23,45,68,90,113,135,158,180,203,225,248,270,293,315,338",
",")
For x = 0 To 15
lDrc(x) = CLng(sTmp(x))
Next
Randomize
For lRow = 17 To 26000
Cells(lRow, 1).Value = sDrc(Int(16 * Rnd))
Next

' cells in row 1 are filled with random values from sDrc
For lRow = 17 To 26000
For x = 0 To 15
If Cells(lRow, 1).Value = sDrc(x) Then
Cells(lRow, 2).Value = lDrc(x)
End If
Next
Next

MsgBox Time - lTime
End Sub
' -------------------------------------------------------------


HTH

--
Greetings from Bavaria, Germany

Helmut Weber, MVP WordVBA

Win XP, Office 2003
"red.sys" & Chr$(64) & "t-online.de"

 

[Norman Jones]

Hi Norm,

Alternatively, try:

'<<=============
Public Sub Tester()
Dim WB As Workbook
Dim SH As Worksheet
Dim Rng As Range
Dim rCell As Range
Dim iLastRow As Long
Dim ArrText As Variant
Dim ArrDeg As Variant
Dim CalcMode As Long
Dim res As Variant

Set WB = Workbooks("MyBook.xls") '<<=== CHANGE
Set SH = WB.Sheets("Sheet1") '<<=== CHANGE

iLastRow = SH.Cells(Rows.Count, "A").End(xlUp).Row

Set Rng = SH.Range("N17:A" & iLastRow) '

ArrText = VBA.Array("N", "NNE", "NE", "ENE", "E", "ESE", _
"SE", "SSE", "S", "SSW", "SW", "WSW", _
"W", "WNW", "NW", "NNW")

ArrDeg = VBA.Array(0, 23, 45, 68, 90, 113, 135, 158, 180, _
203, 225, 248, 270, 293, 315, 338)

On Error GoTo XIT
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With

For Each rCell In Rng.Cells
With rCell
res = Application.Match(.Value, ArrText, 0)
If Not IsError(res) Then
.Value = ArrDeg(res - 1)
End If
End With
Next rCell

XIT:
With Application
.Calculation = CalcMode
.ScreenUpdating = True
End With
End Sub
'<<=============

 

[Guest]

Thank you all for the responses and suggestions. I ended up using Norman's
script because that was what I was most familiar with. It worked great. I
really appreciate it. One of these days I should to take a VB class.

Thanks again,
Norm

 

[Carl Hartness]

Hi Norm,

If you run this a lot, reading the range into an array and working
within memory is much faster than so many individual cell references.

'In Norman's macro, add
Dim ary As Variant, x As Integer

'change
Set Rng = SH.Range("N17:A" & iLastRow) to
Set Rng = SH.Range("N17:B" & iLastRow) to make a 2 column array

'replace the "For Each rCell In Rng.Cells" loop with
' column 1 holds the directions, column 2 the degrees
' read columns 1, 2 into the array
ary = Rng
For x = 1 To UBound(ary, 1)
res = Application.Match(ary(x, 1), ArrText, 0)
If Not IsError(res) Then
' set column 2
ary(x, 2) = ArrDeg(res - 1)
End If
Next x
' put the array to columns 1, 2
Rng = ary

Carl.