Sub cal()
Dim wN As Double '北
Dim wNNE As Double '北东北
Dim wNE As Double '东北
Dim wENE As Double '东东北
Dim wE As Double '东
Dim wESE As Double '东东南
Dim wSE As Double '东南
Dim wSSE As Double '南东南
Dim wS As Double '南
Dim wSSW As Double '南西南
Dim wSW As Double '西南
Dim wWSW As Double '西西南
Dim wW As Double '西
Dim wWNW As Double '西西北
Dim wNW As Double '西北
Dim wNNW As Double '北西北
Dim vN As Double '北
Dim vNNE As Double '北东北
Dim vNE As Double '东北
Dim vENE As Double '东东北
Dim vE As Double '东
Dim vESE As Double '东东南
Dim vSE As Double '东南
Dim vSSE As Double '南东南
Dim vS As Double '南
Dim vSSW As Double '南西南
Dim vSW As Double '西南
Dim vWSW As Double '西西南
Dim vW As Double '西
Dim vWNW As Double '西西北
Dim vNW As Double '西北
Dim vNNW As Double '北西北
Dim num As Integer '1-12
Dim i As Integer '6-66
Dim j As Integer '3-26
Dim nameid As Integer '1-15
For num = 1 To Sheets.Count
For i = 6 To 66 Step 2
For j = 3 To 26
If Sheets(num).Cells(i, j) <> "" Then
If Sheets(num).Cells(i, j) > 348.76 Or Sheets(num).Cells(i, j) < 11.25 Then
If Sheets(num).Cells(i + 1, j) > 5# Then
wN = wN + 1
vN = vN + Sheets(num).Cells(i + 1, j)
End If
ElseIf Sheets(num).Cells(i, j) > 11.26 And Sheets(num).Cells(i, j) < 33.75 Then
If Sheets(num).Cells(i + 1, j) > 5# Then
wNNE = wNNE + 1
vNNE = vNNE + Sheets(num).Cells(i + 1, j)
End If
ElseIf Sheets(num).Cells(i, j) > 33.76 And Sheets(num).Cells(i, j) < 56.25 Then
If Sheets(num).Cells(i + 1, j) > 5# Then
wNE = wNE + 1
vNE = vNE + Sheets(num).Cells(i + 1, j)
End If
ElseIf Sheets(num).Cells(i, j) > 56.26 And Sheets(num).Cells(i, j) < 78.75 Then
If Sheets(num).Cells(i + 1, j) > 5# Then
wENE = wENE + 1
vENE = vENE + Sheets(num).Cells(i + 1, j)
End If
ElseIf Sheets(num).Cells(i, j) > 78.76 And Sheets(num).Cells(i, j) < 101.25 Then
If Sheets(num).Cells(i + 1, j) > 5# Then
wE = wE + 1
vE = vE + Sheets(num).Cells(i + 1, j)
End If
ElseIf Sheets(num).Cells(i, j) > 101.26 And Sheets(num).Cells(i, j) < 123.75 Then
If Sheets(num).Cells(i + 1, j) > 5# Then
wESE = wESE + 1
vESE = vESE + Sheets(num).Cells(i + 1, j)
End If
ElseIf Sheets(num).Cells(i, j) > 123.76 And Sheets(num).Cells(i, j) < 146.25 Then
If Sheets(num).Cells(i + 1, j) > 5# Then
wSE = wSE + 1
vSE = vSE + Sheets(num).Cells(i + 1, j)
End If
ElseIf Sheets(num).Cells(i, j) > 146.26 And Sheets(num).Cells(i, j) < 168.75 Then
If Sheets(num).Cells(i + 1, j) > 5# Then
wSSE = wSSE + 1
vSSE = vSSE + Sheets(num).Cells(i + 1, j)
End If
ElseIf Sheets(num).Cells(i, j) > 168.76 And Sheets(num).Cells(i, j) < 191.25 Then
If Sheets(num).Cells(i + 1, j) > 5# Then
wS = wS + 1
vS = vS + Sheets(num).Cells(i + 1, j)
End If
ElseIf Sheets(num).Cells(i, j) > 191.26 And Sheets(num).Cells(i, j) < 213.75 Then
If Sheets(num).Cells(i + 1, j) > 5# Then
wSSW = wSSW + 1
vSSW = vSSW + Sheets(num).Cells(i + 1, j)
End If
ElseIf Sheets(num).Cells(i, j) > 213.76 And Sheets(num).Cells(i, j) < 236.25 Then
If Sheets(num).Cells(i + 1, j) > 5# Then
wSW = wSW + 1
vSW = vSW + Sheets(num).Cells(i + 1, j)
End If
ElseIf Sheets(num).Cells(i, j) > 236.26 And Sheets(num).Cells(i, j) < 258.75 Then
If Sheets(num).Cells(i + 1, j) > 5# Then
wWSW = wWSW + 1
vWSW = vWSW + Sheets(num).Cells(i + 1, j)
End If
ElseIf Sheets(num).Cells(i, j) > 258.76 And Sheets(num).Cells(i, j) < 281.25 Then
If Sheets(num).Cells(i + 1, j) > 5# Then
wW = wW + 1
vW = vW + Sheets(num).Cells(i + 1, j)
End If
ElseIf Sheets(num).Cells(i, j) > 281.26 And Sheets(num).Cells(i, j) < 303.75 Then
If Sheets(num).Cells(i + 1, j) > 5# Then
wWNW = wWNW + 1
vWNW = vWNW + Sheets(num).Cells(i + 1, j)
End If
ElseIf Sheets(num).Cells(i, j) > 303.76 And Sheets(num).Cells(i, j) < 326.25 Then
If Sheets(num).Cells(i + 1, j) > 5# Then
wNW = wNW + 1
vNW = vNW + Sheets(num).Cells(i + 1, j)
End If
ElseIf Sheets(num).Cells(i, j) > 326.26 And Sheets(num).Cells(i, j) < 348.75 Then
If Sheets(num).Cells(i + 1, j) > 5# Then
wNNW = wNNW + 1
vNNW = vNNW + Sheets(num).Cells(i + 1, j)
End If
End If
End If
Next j
Next i
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim filename As String
filename = ""
For nameid = 1 To 15
filename = filename & Sheets(num).Cells(4, nameid)
Next nameid
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim sFile As Object, FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
Set sFile = FSO.CreateTextFile("C:\" & filename & ".txt", True)
sFile.WriteLine ("wN" & vbTab & wN)
sFile.WriteLine ("wNNE" & vbTab & wNNE)
sFile.WriteLine ("wNE" & vbTab & wNE)
sFile.WriteLine ("wENE" & vbTab & wENE)
sFile.WriteLine ("wE" & vbTab & wE)
sFile.WriteLine ("wESE" & vbTab & wESE)
sFile.WriteLine ("wSE" & vbTab & wSE)
sFile.WriteLine ("wSSE" & vbTab & wSSE)
sFile.WriteLine ("wS" & vbTab & wS)
sFile.WriteLine ("wSSW" & vbTab & wSSW)
sFile.WriteLine ("wSW" & vbTab & wSW)
sFile.WriteLine ("wWSW" & vbTab & wWSW)
sFile.WriteLine ("wW" & vbTab & wW)
sFile.WriteLine ("wWNW" & vbTab & wWNW)
sFile.WriteLine ("wNW" & vbTab & wNW)
sFile.WriteLine ("wNNW" & vbTab & wNNW)
''''''''''''''''''''''''''''''''''
sFile.WriteLine ("vN" & vbTab & vN)
sFile.WriteLine ("vNNE" & vbTab & vNNE)
sFile.WriteLine ("wNE" & vbTab & wNE)
sFile.WriteLine ("vENE" & vbTab & vENE)
sFile.WriteLine ("vE" & vbTab & vE)
sFile.WriteLine ("vESE" & vbTab & vESE)
sFile.WriteLine ("vSE" & vbTab & vSE)
sFile.WriteLine ("vSSE" & vbTab & vSSE)
sFile.WriteLine ("vS" & vbTab & vS)
sFile.WriteLine ("vSSW" & vbTab & vSSW)
sFile.WriteLine ("vSW" & vbTab & vSW)
sFile.WriteLine ("vWSW" & vbTab & vWSW)
sFile.WriteLine ("vW" & vbTab & vW)
sFile.WriteLine ("vWNW" & vbTab & vWNW)
sFile.WriteLine ("vNW" & vbTab & vNW)
sFile.WriteLine ("vNNW" & vbTab & vNNW)
sFile.Close
Set sFile = Nothing
Set FSO = Nothing
Next num
MsgBox "计算完成"
End Sub
分类:
Office VBA
