[★下载交流]：EXCEL.VBA函数求全线设计高程及临界坡度

zml84

一、需求
在工作中，经常要查询路线上某桩号的设计标高及临界坡度，所以在EXCEL中写了两个自定义函数，来计算它们。
<br>
二、介绍
工作薄中共有三个工作表，它们是："工作场地"、"纵断面资料"、"断链资料"
其中，"纵断面资料"中添入路线纵断面设计线变坡点三个参数（即桩号、高程、竖曲线半径）；
"断链资料"中填入路线中的断链信息，每个断链需要填入来向桩号与去向桩号。若路线中未设置断链，则只填入一对较大的数字即可；
"工作场地"是为了与达到与输入的数据相隔离的目的，所有的计算就在这个工作表中进行。
<br>
三、计算应用
  a.  比如要计算K1+250处的设计高程，则只需要在某一单元格中输入:

1. 
   
2. =高程(1250)
   

复制代码

回车后，即可显示该桩号处的设计高程值。
  b.  EXCEL中自定义的函数与其本身的函数一样支持引用和被引用。例如要在 A3单元格 显示 A1单元格中的桩号 对应的 设计高程，则可以在A3单元格中输入：

1. 
   
2. =高程(A1)
   

复制代码

更进一步，要在该高程上减去铺装厚度0.18m，则修改A3单元格：

1. 
   
2. =高程(A1)-0.18
   

复制代码

即可。
<br>
四、核心代码
[PHP]
'''定义函数  高程（）
'''用于查询路线全线纵断设计高程
'''2005-10-29
Function 高程(桩号 As Double) As Double
    zh = 桩号
   
   
    '''第一步：读入断链信息
    d1 = Sheet2.Cells(1, 1)
    d2 = Sheet2.Cells(1, 2)
    dj = d2 - d1 '断链长度
    'MsgBox d2
    If zh >= d2 Then
        lc = zh - dj
    ElseIf zh > d1 Then
            z = "路线中无此桩号，请注意断链！"
            GoTo js
        Else
            lc = zh
    End If
   
   
    '''第二步：读入纵断高程设计信息并计算必要要素
    gs = 85 '变坡点个数
    Dim BPD(85, 6) As Double
    '5列分别为：变坡点桩号；高程；半径；到前一变坡点间纵坡；
   
    BPD(1, 1) = Sheet1.Cells(1, 1) '起始桩号
    BPD(1, 2) = Sheet1.Cells(1, 2) '起始高程
    If lc < BPD(1, 1) Then
        z = "桩号过小，请检查！"
        GoTo js
    End If
   
    For i = 2 To gs
        For j = 1 To 3
            If j = 1 And Sheet1.Cells(i, j) >= d2 Then
            BPD(i, j) = Sheet1.Cells(i, j) - dj
            Else
            BPD(i, j) = Sheet1.Cells(i, j)
            End If
        'MsgBox BPD(I, J)
        Next j
        '计算与前一变坡点之间的纵坡
        zpi = (BPD(i, 2) - BPD(i - 1, 2)) / (BPD(i, 1) - BPD(i - 1, 1))
        BPD(i, 4) = zpi
    Next i
   
    '计算切线长
    For i = 2 To gs - 1
        ti = Abs(BPD(i + 1, 4) - BPD(i, 4)) * BPD(i, 3) / 2
        't=(i1-i2)*R/2
        BPD(i, 5) = ti
        'MsgBox "第" & i & "个变坡点切线长：" & BPD(I, 5)
        If BPD(i + 1, 4) > BPD(i, 4) Then '凸凹标记：凹为1
            BPD(i, 6) = 1
        Else
            BPD(i, 6) = -1
        End If
    Next i
   
   
    '''第三步：判断区间并计算高程
    If lc > BPD(gs, 1) Then
        z = "桩号过大，请检查！"
        GoTo js
    End If
    'z1为直线高程
    'z2为竖曲线改正值
    'z=z1+z2
   
    '下面计算z1
    z1 = 0
    For i = 2 To gs
        If lc < BPD(i, 1) Then
            z1 = BPD(i - 1, 2) + (lc - BPD(i - 1, 1)) * BPD(i, 4)
            'MsgBox "路线纵坡＝" & BPD(i, 4)
            Exit For
        End If
    Next i
   
    '下面计算z2
    z2 = 0
    For i = 2 To gs - 1
        If Abs(BPD(i, 1) - lc) < BPD(i, 5) Then
            'z2=L*L/2/R
            z2 = (BPD(i, 5) - Abs(BPD(i, 1) - lc)) ^ 2 / (2 * BPD(i, 3)) * BPD(i, 6)
            Exit For
        End If
    Next i
   
    '''第四步：结果汇总
    'z = Int((z1 + z2) * 10000 + 0.5) / 10000
    z = z1 + z2
   
    高程 = z

js: End Function
[/PHP]

好为人师

为什么下载不了?害我浪费三个金币,请发到我的信箱 liaoyilily@sina.com,谢谢

zml84

1楼的附件重新上传。
有谁肯出手为它做个图形界面？

zml84

最初由 好为人师 发布
[B]为什么下载不了?害我浪费三个金币,请发到我的信箱 liaoyilily@sina.com,谢谢 [/B]

实在对不住了，邮件已发，请查收。

1968cjz

你好！下不了，请发至：1968cjz@sina.com,谢谢

zml84

最初由 1968cjz 发布
[B]你好！下不了，请发至：1968cjz@sina.com,谢谢 [/B]

邮件已发，请注意查收；对于不能直接下载，深表遗憾。
<br>
再试：

pym_54

你好！的确下不了，
请发至：pengyingmian@163.com
谢谢

zml84

[B] pym_54 [/B]
邮件已发，请查收！

engineerlzk

下载不了！请发engineerlzk@163.com

buck50

楼主请给我也发一个吧
buck50@163.com

pym_54

最初由 zml84 发布
[B][B] pym_54 [/B]
邮件已发，请查收！ [/B]

我没有收到，请楼主重新发一下好吗？
pengyingmian@163.com

谢谢。

mutou227

下不了啊！
可以给我发一个吗？
mutou227@163.com
深表感谢！

zml84

邮件已发，请各位查收。
希望提出宝贵意见。
附加重新上传，希望能够下载。
这里也可以下载：http://co.163.com/forum/content/1665_737521_1.htm

JGL-XJ

怎么样才能下啊,谢谢

zml84

1楼附件下载请到： ftp://kilu.net/%D7%CA%C1%CF/     下载  “全线纵断面高程查询.rar”
<br>
已在网易土木注册的兄弟，请到<a href="http://co.163.com/forum/content/1665_737521_1.htm" target="_blank">http://co.163.com/forum/content/1665_737521_1.htm</a>