VBA水准平差

最新推荐文章于 2022-05-21 09:14:27 发布

花舞月咏潭

最新推荐文章于 2022-05-21 09:14:27 发布

阅读量335

点赞数

分类专栏： VBA 水准文章标签：开发语言

本文链接：https://blog.csdn.net/sinat_25006091/article/details/123633541

版权

VBA 同时被 2 个专栏收录

27 篇文章 0 订阅

订阅专栏

水准

10 篇文章 0 订阅

订阅专栏

Public Enum Workenum
RgCola = 1
rgcolb = 2
rgcolc = 3
RgCold = 4
RgCole = 5
RgColf = 6
RgColg = 7
RgColh = 8
RgColi = 9
RgColj = 10
RgColk = 11
RgColl = 12
RgColo = 15
Rgcolp = 16
End Enum
Const WorkNameYs As String = "原测数据"
Const WorkNameCg As String = "过程数据"
Const WorkNameGc As String = "线路高差"
Const WorkNameSj As String = "平差数据"
Const sttp As String = "TP"
Private Function WorkFunction(s As Double, b As Boolean) As Double '获取后视、前视视距函数
Dim Fx As WorksheetFunction
Dim y As Long, x As Long, z As Double, w As Variant
Set Fx = WorksheetFunction
If b Then
y = 100
x = 10
z = 0.1
Else
' w5 = InStr(s, ".")
'w6 = Len(s)
y = 1000000
x = 100000
z = 0.00001
End If

Select Case Right(s, 1) * 1 'Select Case Right(Int(s * y), 1) * 1
Case 5 '小数最后一位是5
If Left(Right(s, 2), 1) <> "." Then
If Left(Right(s, 2), 1) * 1 Mod 2 = 0 Then '如果5前一位是偶数
WorkFunction = Fx.Floor(s, z) '向下舍入
Else
WorkFunction = Fx.Ceiling(s, z) '反之向上舍入
End If
Else
WorkFunction = Fx.Floor(s, z)
End If
Case Is > 5
WorkFunction = Fx.Ceiling(s, z)
Case Is < 5
WorkFunction = Fx.Floor(s, z)
End Select
Set Fx = Nothing
End Function

Public Sub Workarray()
Dim brr As Variant
Dim arr(), crr(RgCola To rgcolc, RgCola To RgColg)
Dim i%, t As Double, c As Double, u As Double, j%, n%, l%, h As Double, w As Double, o%, s%
brr = Sheets(WorkNameYs).UsedRange
ReDim arr(RgCola To UBound(brr) * rgcolc, RgCola To RgColh)
i = RgCola
n = RgCola
Do While i <= UBound(brr)
If brr(i, RgCola) <> "" Then
crr(RgCola, RgCola) = brr(i, RgCola) '点号
crr(rgcolb, RgCola) = brr(i, RgColj)

t = brr(i, rgcolb)
crr(RgCola, rgcolb) = WorkFunction(t, True) '后视距
t = brr(i, RgColk)
crr(rgcolb, rgcolb) = WorkFunction(t, True) '前视距

'-----------------------------------------------------------------------------------------------------------
crr(rgcolb, rgcolc) = crr(RgCola, rgcolb) - crr(rgcolb, rgcolb) '视距差
If Abs(crr(rgcolb, rgcolc)) > 1.5 Then
GetStadiaDifference crr

End If

crr(rgcolc, rgcolc) = Round(c + crr(rgcolb, rgcolc), RgCola) '累积视距差
c = crr(rgcolc, rgcolc)
If Abs(c) > 5 Then
GetChange crr, c
c = crr(3, 3) + crr(2, 3)
crr(3, 3) = c
End If



crr(RgCola, RgCold) = brr(i, rgcolc)
crr(RgCola, RgCole) = brr(i, RgColg)

crr(rgcolb, RgCold) = brr(i, RgColl)
crr(rgcolb, RgCole) = brr(i, Rgcolp)

crr(rgcolc, RgCold) = Round(crr(RgCola, RgCold) - crr(rgcolb, RgCold), RgCole)
crr(rgcolc, RgCole) = Round(crr(RgCola, RgCole) - crr(rgcolb, RgCole), RgCole)

crr(RgCola, RgColf) = Round((crr(RgCola, RgCold) - crr(RgCola, RgCole)) * 100000, 0)
crr(rgcolb, RgColf) = Round((crr(rgcolb, RgCold) - crr(rgcolb, RgCole)) * 100000, 0)
crr(rgcolc, RgColf) = Round((crr(rgcolc, RgCold) - crr(rgcolc, RgCole)) * 100000, 0)

u = (crr(rgcolc, RgCold) + crr(rgcolc, RgCole)) / rgcolb

crr(rgcolc, RgColg) = WorkFunction(Abs(u), False)

If u < 0 Then crr(rgcolc, RgColg) = crr(rgcolc, RgColg) * -1


For j = RgCola To rgcolc
For l = RgCola To RgColg
arr(n, l) = crr(j, l)
Next
n = n + 1
Next
End If
i = i + 1
Loop

'调用检验视距差过程

'********************

If n > UBound(arr) Then o = UBound(arr) Else o = n
With Sheets(WorkNameCg)
.UsedRange.Offset(5).ClearContents
.Range("B:C").NumberFormatLocal = "0.0"
.Range("a6").Resize(o, UBound(arr, 2)) = arr
With .Range("g" & o + RgColf)
.Formula = "=SUM(G6:G" & o + RgCole & ")"
.Offset(, -1) = "∑"
End With
GetGaoC
End With
End Sub
'*****************************************************
'*前后视距差不应该超过1.5m，视距累积差始终不超过5m *
'*两个数求和再取二分之一，加个随机数，零差值小于1.5m就行 *
'******************************************************
Private Sub GetStadiaDifference(arr()) '效验视距差

Dim rou1 As Double, rou2 As Double, ss As Double
Randomize
Do
sum1 = (arr(1, 2) + arr(2, 2)) / 2
w = Round(Rnd() * 1.5, 2)
rou1 = Round((sum1 - w), 1)
rou2 = Round((sum1 + w), 1)
ss = rou1 - rou2
If Abs(ss) < 1.5 Then
arr(1, 2) = rou1
arr(2, 2) = rou2
arr(2, 3) = ss
Exit Do
End If
Loop
End Sub
Private Sub GetChange(arr(), t As Double)
Dim rou1 As Double, rou2 As Double, ss As Double
rou1 = arr(1, 2)
arr(1, 2) = arr(2, 2)
arr(2, 2) = rou1
arr(2, 3) = arr(1, 2) - arr(2, 2)
arr(3, 3) = t + arr(2, 3)
End Sub
Public Sub GetPc()
Dim brr, i%, n%, c%, l%, dic As Object
Dim Dsum As Double
Dim arr(1 To 5000, 1 To 4)
Const cla% = 6
Const clb% = 10
Const clc% = 11
Const cld% = 14
Const sta As String = "h0"
Const stb As String = "n0"

brr = Sheets(WorkNameCg).UsedRange

For i = cla To UBound(brr) Step 3
If brr(i, 1) <> sttp And brr(i, 1) <> "" Then
n = n + 1
arr(n, 1) = brr(i, 1)
Dsum = brr(i + 2, 7)
If brr(i + 1, 1) <> sttp Then
arr(n, 2) = brr(i + 1, 1)
Else
l = i + 1
Dsum = 0
Do
If brr(l, 1) <> "" And brr(l, 1) <> sttp Then
arr(n, 2) = brr(l, 1)
Exit Do
Else
If brr(l, 1) = sttp And brr(l + 1, 1) <> sttp Then
c = c + 1
If brr(l + 1, 7) <> "" Then Dsum = Dsum + brr(l + 1, 7) Else Dsum = Dsum + brr(l + 2, 7)

End If
End If
l = l + 1
Loop
End If
arr(n, 3) = sta
arr(n, 4) = Dsum
n = n + 1
arr(n, 2) = arr(n - 1, 2)
arr(n, 3) = stb
arr(n, 4) = IIf(c = 0, 1, c)
c = 0
Dsum = 0
n = n + 2
End If
Next

With Sheets(WorkNameSj)
.Cells.ClearContents
.Range("a6").Resize(n, 4) = arr
End With
End Sub

Private Sub GetGaoC()
Dim brr, l%, i%
Dim Dsum As Double
Dim strc As String
brr = Sheets(WorkNameCg).UsedRange
For i = 6 To UBound(brr) Step 3
If brr(i, 1) <> sttp And brr(i, 1) <> "" Then
strc = brr(i, 1)
If brr(i + 1, 1) = sttp Then
l = i + 1
Do
If brr(l, 1) <> "" And brr(l, 1) <> sttp Then
strc = strc & "-" & brr(l, 1)
Range("h" & l) = strc
Range("h" & l + 1) = Dsum
Exit Do
Else
If brr(l, 1) = sttp And brr(l + 1, 1) <> sttp Then
If brr(l + 1, 7) <> "" Then Dsum = Dsum + brr(l + 1, 7) Else Dsum = Dsum + brr(l + 2, 7)
End If
End If
l = l + 1
Loop
End If
Dsum = 0
End If
Next
End Sub