|
傾斜量図など着目するセルに対して8近傍の計算をするものは、端の1セルは計算ができないので、出力範囲は1セル分狭くなる。同様に開度図ではそのまま8方向を計算すると、検索距離分のセルが計算できないので、例えば検索距離を100mとすると、出力範囲は入力範囲に対して周囲100mずつ狭くなる。海岸を含むデータであると、国土地理院DEMでは海上は No Data であるため、海岸線から100mのデータがなくなることになる。 検索距離分、周辺の値がなくなるのを回避するため、 No Data は -9999 とし、計算元データの周囲に、 行、列 とも 検索距離 （セル数） 分、 -9999 を入力しておくこととした。そして計算式に 『-9999 のセルは反映しない』 という条件を加え、また、入力範囲の真ん中に No Data があってそれが着目するセルとなる場合、そのセル位置は -9999 と出力するようにした。 これにより、元データの端でもデータのある方角の値が求められる。例えば北西角であれば、東、南東、南の3方向の標高差/距離が算出されるようにした。同時に、5mDEMもそのまま計算できるようになった。 地上開度では求める方向の最大値を抽出するので、その方向に -9999 があってもこれが最大値として選択されることはない。検索セルがすべて -9999 のことを想定し、とりあえず標高差/距離の最大値が -10 より小さければ、その方向は平均値を出す際の方向数から除くこととしてみた。 検索セルがすべて -9999 で着目するセルの標高が 0m の場合で、検索距離が 1km 以上だと標高差/距離は -9.99 より大きくなってしまう。しかし、現実の地形でこのようなケースはまずないと思われる。 地下開度では求める方向の最小値を抽出するので、計算セルに -9999 があれば標高差/距離の値を 10 とするようにした。そしてその方向の最小値が 10 であれば、その方向は平均値を出す際の方向数から除くこととした。 |
Sub 開度図計算()
'
Dim I, J, n, Dxn, Dyn, Dxyn As Integer
Dim h1, h2, h3, h4, h5, h6, h7, h8 As Double
Dim h1t, h2t, h3t, h4t, h5t, h6t, h7t, h8t As Double
Dim k1, k2, k3, k4, k5, k6, k7, k8 As Double
Dim k1t, k2t, k3t, k4t, k5t, k6t, k7t, k8t As Double
Dim Dx, Dy, Dxy As Double
Dim MyTime0, MyTime1
Dim h(8), k(8), Hsum, Ksum As Double
Dim Mu, Md, L As Integer
Dim Mydatu(5000) As Variant
Dim Mydatd(5000) As Variant
'
If Sheets(1).Name = "変換シート" Then
MsgBox "データシート位置が不適切", vbInformation
Exit Sub
End If
Range(Range("f12"), ActiveCell.SpecialCells(xlLastCell)).Clear
MyTime0 = Time + Date
[h9] = "開度図計算 （検索距離 " & [e2] & " m）"
[e8] = "計算中"
[b9] = "計算中"
[b8] = MyTime0
[e10] = [b8] + [e9]
'
Dxn = [e3] 'X方向検索セル数
Dyn = [e4] 'Y方向検索セル数
Dxyn = [e5] '対角方向検索セル数
Dx = [d3] 'X方向距離
Dy = [d4] 'Y方向距離
Dxy = [d5] '対角方向距離
Range("d8").NumberFormatLocal = "0.00_ "
With Range("D8:E8").Font
.Color = -16776961
.TintAndShade = 0
.Bold = True
End With
With Range("D8:E8").Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
'
Cells(Dyn + 10, 9) = "地上開度"
Cells(Dyn + [i5] + 15, 9) = "地下開度"
'
For I = Dyn + 1 To Dyn + [i5]
[e8] = "% 計算中"
[d8] = (I - Dyn) / [i5] * 100
For J = Dxn + 1 To Dxn + [j5]
Vr = I + [i3] - 1
Vc = J + [j3] - 1
'
If Worksheets(1).Cells(Vr, Vc) = -9999 Then
' Cells(I + 11, J) = -9999
Mydatu(J - Dxn - 1) = -9999
Mydatd(J - Dxn - 1) = -9999
Else
h(2) = (Worksheets(1).Cells(Vr, Vc + 1) - Worksheets(1).Cells(Vr, Vc)) / Dx
h(6) = (Worksheets(1).Cells(Vr, Vc - 1) - Worksheets(1).Cells(Vr, Vc)) / Dx
h(4) = (Worksheets(1).Cells(Vr + 1, Vc) - Worksheets(1).Cells(Vr, Vc)) / Dy
h(8) = (Worksheets(1).Cells(Vr - 1, Vc) - Worksheets(1).Cells(Vr, Vc)) / Dy
h(1) = (Worksheets(1).Cells(Vr - 1, Vc + 1) - Worksheets(1).Cells(Vr, Vc)) / Dxy
h(3) = (Worksheets(1).Cells(Vr + 1, Vc + 1) - Worksheets(1).Cells(Vr, Vc)) / Dxy
h(5) = (Worksheets(1).Cells(Vr + 1, Vc - 1) - Worksheets(1).Cells(Vr, Vc)) / Dxy
h(7) = (Worksheets(1).Cells(Vr - 1, Vc - 1) - Worksheets(1).Cells(Vr, Vc)) / Dxy
If Worksheets(1).Cells(Vr, Vc + 1) = -9999 Then
k(2) = 10
Else
k(2) = (Worksheets(1).Cells(Vr, Vc + 1) - Worksheets(1).Cells(Vr, Vc)) / Dx
End If
If Worksheets(1).Cells(Vr, Vc - 1) = -9999 Then
k(6) = 10
Else
k(6) = (Worksheets(1).Cells(Vr, Vc - 1) - Worksheets(1).Cells(Vr, Vc)) / Dx
End If
If Worksheets(1).Cells(Vr + 1, Vc) = -9999 Then
k(4) = 10
Else
k(4) = (Worksheets(1).Cells(Vr + 1, Vc) - Worksheets(1).Cells(Vr, Vc)) / Dy
End If
If Worksheets(1).Cells(Vr - 1, Vc) = -9999 Then
k(8) = 10
Else
k(8) = (Worksheets(1).Cells(Vr - 1, Vc) - Worksheets(1).Cells(Vr, Vc)) / Dy
End If
If Worksheets(1).Cells(Vr - 1, Vc + 1) = -9999 Then
k(1) = 10
Else
k(1) = (Worksheets(1).Cells(Vr - 1, Vc + 1) - Worksheets(1).Cells(Vr, Vc)) / Dxy
End If
If Worksheets(1).Cells(Vr + 1, Vc + 1) = -9999 Then
k(3) = 10
Else
k(3) = (Worksheets(1).Cells(Vr + 1, Vc + 1) - Worksheets(1).Cells(Vr, Vc)) / Dxy
End If
If Worksheets(1).Cells(Vr + 1, Vc - 1) = -9999 Then
k(5) = 10
Else
k(5) = (Worksheets(1).Cells(Vr + 1, Vc - 1) - Worksheets(1).Cells(Vr, Vc)) / Dxy
End If
If Worksheets(1).Cells(Vr - 1, Vc - 1) = -9999 Then
k(7) = 10
Else
k(7) = (Worksheets(1).Cells(Vr - 1, Vc - 1) - Worksheets(1).Cells(Vr, Vc)) / Dxy
End If
'
For n = 2 To Dxn
If Worksheets(1).Cells(Vr, Vc + n) = -9999 Then
k2t = 10
Else
k2t = (Worksheets(1).Cells(Vr, Vc + n) - Worksheets(1).Cells(Vr, Vc)) / (Dx * n)
End If
h2t = (Worksheets(1).Cells(Vr, Vc + n) - Worksheets(1).Cells(Vr, Vc)) / (Dx * n)
h(2) = WorksheetFunction.Max(h(2), h2t)
k(2) = WorksheetFunction.Min(k(2), k2t)
If Worksheets(1).Cells(Vr, Vc - n) = -9999 Then
k6t = 10
Else
k6t = (Worksheets(1).Cells(Vr, Vc - n) - Worksheets(1).Cells(Vr, Vc)) / (Dx * n)
End If
h6t = (Worksheets(1).Cells(Vr, Vc - n) - Worksheets(1).Cells(Vr, Vc)) / (Dx * n)
h(6) = WorksheetFunction.Max(h(6), h6t)
k(6) = WorksheetFunction.Min(k(6), k6t)
Next
For n = 2 To Dyn
If Worksheets(1).Cells(Vr + n, Vc) = -9999 Then
k4t = 10
Else
k4t = (Worksheets(1).Cells(Vr + n, Vc) - Worksheets(1).Cells(Vr, Vc)) / (Dy * n)
End If
h4t = (Worksheets(1).Cells(Vr + n, Vc) - Worksheets(1).Cells(Vr, Vc)) / (Dy * n)
h(4) = WorksheetFunction.Max(h(4), h4t)
k(4) = WorksheetFunction.Min(k(4), k4t)
If Worksheets(1).Cells(Vr - n, Vc) = -9999 Then
k8t = 10
Else
k8t = (Worksheets(1).Cells(Vr - n, Vc) - Worksheets(1).Cells(Vr, Vc)) / (Dy * n)
End If
h8t = (Worksheets(1).Cells(Vr - n, Vc) - Worksheets(1).Cells(Vr, Vc)) / (Dy * n)
h(8) = WorksheetFunction.Max(h(8), h8t)
k(8) = WorksheetFunction.Min(k(8), k8t)
Next
For n = 2 To Dxyn
If Worksheets(1).Cells(Vr - n, Vc + n) = -9999 Then
k1t = 10
Else
k1t = (Worksheets(1).Cells(Vr - n, Vc + n) - Worksheets(1).Cells(Vr, Vc)) / (Dxy * n)
End If
h1t = (Worksheets(1).Cells(Vr - n, Vc + n) - Worksheets(1).Cells(Vr, Vc)) / (Dxy * n)
h(1) = WorksheetFunction.Max(h(1), h1t)
k(1) = WorksheetFunction.Min(k(1), k1t)
If Worksheets(1).Cells(Vr + n, Vc + n) = -9999 Then
k3t = 10
Else
k3t = (Worksheets(1).Cells(Vr + n, Vc + n) - Worksheets(1).Cells(Vr, Vc)) / (Dxy * n)
End If
h3t = (Worksheets(1).Cells(Vr + n, Vc + n) - Worksheets(1).Cells(Vr, Vc)) / (Dxy * n)
h(3) = WorksheetFunction.Max(h(3), h3t)
k(3) = WorksheetFunction.Min(k(3), k3t)
If Worksheets(1).Cells(Vr + n, Vc - n) = -9999 Then
k5t = 10
Else
k5t = (Worksheets(1).Cells(Vr + n, Vc - n) - Worksheets(1).Cells(Vr, Vc)) / (Dxy * n)
End If
h5t = (Worksheets(1).Cells(Vr + n, Vc - n) - Worksheets(1).Cells(Vr, Vc)) / (Dxy * n)
h(5) = WorksheetFunction.Max(h(5), h5t)
k(5) = WorksheetFunction.Min(k(5), k5t)
If Worksheets(1).Cells(Vr - n, Vc - n) = -9999 Then
k7t = 10
Else
k7t = (Worksheets(1).Cells(Vr - n, Vc - n) - Worksheets(1).Cells(Vr, Vc)) / (Dxy * n)
End If
h7t = (Worksheets(1).Cells(Vr - n, Vc - n) - Worksheets(1).Cells(Vr, Vc)) / (Dxy * n)
h(7) = WorksheetFunction.Max(h(7), h7t)
k(7) = WorksheetFunction.Min(k(7), k7t)
Next
' 地上開度
Mu = 8
Hsum = 0
For L = 1 To 8
If h(L) < -10 Then
h(L) = 0
Mu = Mu - 1
End If
Hsum = Hsum + WorksheetFunction.Atan2(1, h(L))
Next
If Mu = 0 Then
Mydatu(J - Dxn - 1) = -9999
Else
Mydatu(J - Dxn - 1) = WorksheetFunction.Round(90 - Hsum * 180 / Application.Pi() / Mu, 3)
End If
' 地下開度
Md = 8
Ksum = 0
For L = 1 To 8
If k(L) = 10 Then
k(L) = 0
Md = Md - 1
End If
Ksum = Ksum + WorksheetFunction.Atan2(1, k(L))
Next
If Md = 0 Then
Mydatd(J - Dxn - 1) = -9999
Else
Mydatd(J - Dxn - 1) = WorksheetFunction.Round(90 + Ksum * 180 / Application.Pi() / Md, 3)
End If
End If
Next
Range(Cells(I + 11, 8), Cells(I + 11, Range("j5") + 7)) = Mydatu
Range(Cells(I + Range("i5") + 16, 8), Cells(I + Range("i5") + 16, Range("j5") + 7)) = Mydatd
Next
MyTime1 = Time + Date
[e10] = "計算終了"
Range("D8:E8") = Clear
[b9] = MyTime1
[b10] = MyTime1 - MyTime0
[b11] = [b10] / [i5] / [j5] * 1000000
ActiveWorkbook.Save
End Sub