24小时热门版块排行榜

返回列表

askding

金虫 (小有名气)

应助: 0 (幼儿园)
金币: 1674.1
散金: 147
红花: 1
帖子: 148
在线: 122.9小时
虫号: 1334113
注册: 2011-06-29
专业: 景观与区域生态学

[求助] 环境风险评价及作图请教

想做一个环境风险评价的图，使用VBA编程看的不是很懂，有人能帮助下吗？
我试着编了下，求高人帮我看下编的对吗？
如下：在评价区域内，将区域污染源可能影响区域14km×14km的范围网格化，取步长为500 m，形成29行29列的网格。在每个网格对7个源的扩散后的风险值进行迭加得到总和r。然后在Excel中将网格的数据转成X/Y/Z格式。具体编程如下：Sub 环境风险评价()
Dim k As Integer, j As Integer, i As Integer, x As Integer, y As Integer, m As Integer, n As Integer, d1 As Integer, d2 As Integer, d3 As Integer, d4 As Integer, d5 As Integer, d6 As Integer, d7 As Integer, r1 As Double, r2 As Double, r3 As Double, r4 As Double, r5 As Double, r6 As Double, r7 As Double , rr As Double
k=0'定义X轴最小值
For j= 2 To 30
Sheet1.Cells(1,j)=k
k=k+50 '间隔为500m（将实际距离换算成相对坐标系下的距离长度，实际为500m，坐标下为50m）
Next
k=1400 'Y轴最大值
For j=2 To 30
Sheet1.Cells(j,1)=k
k=k-50
Next
x=0
For m=2 To 30
y=1400
For n=2 To 30
Sheet1.Cells(n,m)=Sqr((705-x)^2+(652-y)^2)'输入源1坐标
Sheet1.Cells(n+30,m)=Sqr((690-x)^2+(523-y)^2)'输入源2坐标
Sheet1.Cells(n+60,m)=Sqr((769-x)^2+(416-y)^2)'输入源3坐标
Sheet1.Cells(n+90,m)=Sqr((552-x)^2+(682-y)^2)'输入源4坐标
Sheet1.Cells(n+120,m)=Sqr((758-x)^2+(815-y)^2)'输入源5坐标
Sheet1.Cells(n+150,m)=Sqr((894-x)^2+(983-y)^2)'输入源6坐标
Sheet1.Cells(n+180,m)=Sqr((667-x)^2+(381-y)^2)'输入源7坐标
y=y-50
Next
x=x+50
Next
For m=2 To 30
For n=2 To 30
d1=Sheet1.Cells(n,m)'表示距离
d2=Sheet1.Cells(n+30,m)
d3=Sheet1.Cells(n+60,m)
d4=Sheet1.Cells(n+90,m)
d5=Sheet1.Cells(n+120,m)
d6=Sheet1.Cells(n+150,m)
d7=Sheet1.Cells(n+180,m)
r1=(400-d1)/350*8.33*0.00001'风险值计算,需输入影响半径m
r2=(400-d2)/350*8.33*0.00001
r3=(400-d3)/ 350*8.33*0.00001
r4=(417-d4)/367*8.08*0.0001
r5=(250-d5)/200*9.16*0.00001
r6=(333-d6)/283*5.7*0.00001
r7=(400-d7)/350*3.72*0.001
Sheet2.Cells(n,m)=r1
If r1<0 Then
r1=0
End If
Sheet2.Cells(n+30,m)=r2
If r2<0 Then
r2=0
End If
Sheet2.Cells(n+60,m)=r3
If r3<0 Then
r3=0
End If
Sheet2.Cells(n+90,m)=r4
If r4<0 Then
r4=0
End If
Sheet2.Cells(n+120,m)=r5
If r5<0 Then
r5=0
End If
Sheet2.Cells(n+150,m)=r6
If r6<0 Then
r6=0
End If
Sheet2.Cells(n+180,m)=r7
If r7<0 Then
r7=0
End If
Sheet3.Cells(n,m)=rl+r2+r3+r4+r5+r6+r7
Next
Next
For m=2 To 30
For n=2 To 30
rr=Sheet3.Cells(n,m)
If rr>0 Then
Sheet5.Cells(n,m)=Int(Log(rr)/Log(10)+8)'转化为小数形式,并存入表单5
Else
Sheet5.Cells(n,m)=1
End If
Next
Next
For m=2 To 30
For n=2 To 30
Sheet4.Cells((m-2)*29+n,3)=Sheet5.Cells(n,m)'以YXZ形式存入表单4
Next
Next
For m=2 To 30
For n=2 To 30
Sheet4.Cells((m-2)*29+n,2)=1400-50*(n-2)
Next
Next
For m=2 To 30
For n=2 To 30
Sheet4.Cells((m-2)*29+n,l)=0+(m-2)*50
Next
Next
End Sub

回复此楼