用VBA自动计算水准测量的原始数据

用VBA自动计算水准测量的原始数据

2007-02-09 17:51:30| 分类：默认分类| 标签：水准仪原是数据处理计算 exce vba |字号大中小订阅

Option Explicit

Private Sub gaocheng() '数据处理代码

Dim i, K, Pointer

Dim I_first As Integer, I_end As Integer

I_first = Sheet1.Range("H" & 4).Value

I_end = Sheet1.Range("H" & 5).Value

'开始行要为转点下一行,且转点前一行高程数据已经计算好.

If Sheet1.Range("D" & 1).Value = "1" Then

Pointer = MsgBox("数据已经存在,确定覆盖吗?", vbYesNo + vbInformation, "继续?")

If Pointer = vbNo Then

Exit Sub

End If

End If

K = Sheet1.Range("B" &I_first - 1).Value + Sheet1.Range("C" &I_first - 1).Value

For i = I_first To I_end

If Trim(Sheet1.Range("A" & i).Value) = "ZD" Then

K = Sheet1.Range("B" & i).Value + Sheet1.Range("C" & i - 1).Value Else

Sheet1.Range("C" & i).Value = K - Sheet1.Range("B" & i).Value

End If

Next i

MsgBox "I LOVE 'VBA'" &vbCrLf& "CopyRight by ZZL" &vbCrLf& "liulangr110@", vbInformation, "高程计算完毕"

Sheet1.Range("D" & 1).Value = "1"

End Sub

Private Sub Clear() '清除代码

Dim i

For i = Sheet1.Range("H" & 4).Value To Sheet1.Range("H" & 5).Value

Sheet1.Range("C" & i).Value = Empty

Next i

Sheet1.Range("D" & 1).Value = Empty

End Sub

Sub Macro1() '删除导线点行

Dim i

For i = 1 To 445

If Left(Trim(Sheet2.Range("A" & i).Value), 1) = "D" Then

Rows(i & ":" & i).Select

Selection.Delete SHIFT:=xlUp

End If

Next i

MsgBox "OK"

End Sub

Sub Macro2() '删除转点行

Dim i

For i = 1 To 445

If Sheet2.Range("A" & i).Value = "ZD" Or Trim(Sheet2.Range("A" & i).Value) = "" Then Rows(i & ":" & i).Select

Selection.Delete SHIFT:=xlUp

End If

Next i

End Sub