A VBA script for estimating snow threshold temperature

‘Author: zhb

‘Email: zhanghongbo@itpcas.ac.cn

‘提取固态降水到新增的三列
Sub DividePrec()
Dim OriPrec As Range
Dim OutPrec01 As Range
Dim OutPrec02 As Range
Dim OutPrec03 As Range
Dim Irow As Integer
Dim vall As Integer
Dim vals As String
Set OriPrec = Range(“H3:H20548″)
Set OutPrec01 = Range(“I3:I20548″)
Set OutPrec02 = Range(“J3:J20548″)
Set OutPrec03 = Range(“K3:K20548″)
For Irow = 1 To OriPrec.Rows.Count

        vall = OriPrec.Cells(Irow, 1).Value
If vall >= 30000 And vall <> 32700 And vall <> 32766 And vall <> 32744 Then
vals = RTrim$(LTrim$(Str$(vall)))
vall = val(Right(vals, 3))
Select Case Left(vals, 2)
Case “31”
OutPrec01.Cells(Irow, 1) = vall
Case “30”
OutPrec02.Cells(Irow, 1) = vall
Case “32”
OutPrec03.Cells(Irow, 1) = vall
Case Else
MsgBox “有异常值出现: ” & vals
End Select
End If
Next Irow
MsgBox “完成！”
End Sub

‘计算降雪临界温度

Sub ComputeCriticalTemp()
Const rainPercent As Single = 0.985
Const snowPercent As Single = 0.985
Const sleetPercent As Single = 0.5
Dim Prec As Range
Dim Temp As Range
Dim raint As Range, snowt As Range, sleett As Range
Dim rain() As Single, snow() As Single, sleet() As Single
Dim count1, count2, count3, ac As Integer
Dim Irow As Integer
Dim valt, valp As Single
Dim vals As String
Dim ws0 As Worksheet

Set Temp = ActiveWorkbook.Worksheets(“日值”).Range(“E3:E8463″)
Set Prec = ActiveWorkbook.Worksheets(“日值”).Range(“H3:H8463″)
Set raint = ActiveWorkbook.Worksheets(“日值”).Range(“L3:L8463″)
Set snowt = ActiveWorkbook.Worksheets(“日值”).Range(“M3:M8463″)
Set sleett = ActiveWorkbook.Worksheets(“日值”).Range(“N3:N8463″)
count1 = 0
count2 = 0
count3 = 0

For Irow = 1 To Prec.Rows.Count
valt = Temp.Cells(Irow, 1).Value
valp = Prec.Cells(Irow, 1).Value
If valt = 32766 Or valt = 32744 Then
GoTo Conti
End If
If valp < 30000 Or valp = 32700 Then
count1 = count1 + 1
ReDim Preserve rain(1 To count1) As Single
rain(count1) = valt * 0.1
raint.Cells(Irow, 1) = valt
Else
vals = RTrim$(LTrim$(Str$(valp)))
Select Case Left(vals, 2)
Case “31”
count2 = count2 + 1
ReDim Preserve snow(1 To count2)
snow(count2) = valt * 0.1
snowt.Cells(Irow, 1) = valt
Case “30”
count3 = count3 + 1
ReDim Preserve sleet(1 To count3)
sleet(count3) = valt * 0.1
sleett.Cells(Irow, 1) = valt
End Select
End If
Conti:
Next Irow

    sortByDescending rain
Dim ws As Worksheet
Set ws = ActiveWorkbook.Worksheets(“计算临界温度”)
Dim i As Integer
For i = LBound(rain) To UBound(rain)
ws.Cells(i + 1, 1) = rain(i)
Next i

Call sortByAscending(snow)
For i = LBound(snow) To UBound(snow)
ws.Cells(i + 1, 2) = snow(i)
Next i

Call sortByAscending(sleet)
For i = LBound(sleet) To UBound(sleet)
ws.Cells(i + 1, 3) = sleet(i)
Next i

Dim ind As Integer
Dim inds As Single
inds = (UBound(rain) – LBound(rain) + 1) * rainPercent
If inds > Int(inds) Then
ind = Int(inds) + 1
Else
ind = Int(inds)
End If
ws.Cells(1, 4) = rain(ind)
inds = (UBound(snow) – LBound(snow) + 1) * snowPercent
If inds > Int(inds) Then
ind = Int(inds) + 1
Else
ind = Int(inds)
End If
ws.Cells(1, 5) = snow(ind)
ind = (UBound(sleet) – LBound(sleet) + 1) * sleetPercent
ws.Cells(1, 6) = sleet(ind)

MsgBox Str$(UBound(rain) – LBound(rain) + 1)

End Sub

‘选择排序-降序
Sub sortByDescending(ByRef arr() As Single)
Dim maxIndex As Integer
Dim ac As Integer, i As Integer
Dim max As Single, tmp As Single
For ac = LBound(arr) To UBound(arr) – 1
max = arr(ac)
maxIndex = ac
For i = ac + 1 To UBound(arr)
If arr(i) > max Then
max = arr(i)
maxIndex = i
End If
Next i
If maxIndex <> ac Then
tmp = arr(ac)
arr(ac) = arr(maxIndex)
arr(maxIndex) = tmp
End If
Next ac

End Sub

‘选择排序-升序

Sub sortByAscending(ByRef arr() As Single)
Dim minIndex As Integer
Dim ac As Integer, i As Integer
Dim min As Single, tmp As Single
For ac = LBound(arr) To UBound(arr) – 1
min = arr(ac)
minIndex = ac
For i = ac + 1 To UBound(arr)
If arr(i) < min Then
min = arr(i)
minIndex = i
End If
Next i
If minIndex <> ac Then
tmp = arr(ac)
arr(ac) = arr(minIndex)
arr(minIndex) = tmp
End If
Next ac
End Sub