Dim n, a, b, c As Integer
Dim k As Double
Private Sub Command1_Click()
On Error Resume Next
Dim xlApp As New Excel.Application
Dim xlBook As Excel.Workbook
Dim xlsheet As Excel.Worksheet
xlApp.Visible = False
Set xlBook = xlApp.Workbooks.Open(App.Path & "\three.XLS")
Set xlsheet = xlBook.Worksheets(1)
With xlsheet
On Error Resume Next
n = Val(Text2.Text)
If Not n Mod 2 = 0 Then
MsgBox ("请检查站数是否为偶数")
End
End If
a = 7 + 4 * n
b = 7 + 8 * n
Const k1 = 4.687 '----------计算
Const k2 = 4.787
k = Val(Text1.Text)
If k = k1 Then
For i = 8 To a Step 8 '----------计算往测高差
.Cells(i, 9) = (.Cells(i, 7) - .Cells(i, 8) + k1) * 1000
.Cells(i + 1, 9) = (.Cells(i + 1, 7) - .Cells(i + 1, 8) + k2) * 1000
Next i
For j = 12 To a Step 8
.Cells(j, 9) = (.Cells(j, 7) - .Cells(j, 8) + k2) * 1000
.Cells(j + 1, 9) = (.Cells(j + 1, 7) - .Cells(j + 1, 8) + k1) * 1000
Next j
For i = a + 1 To b Step 8 '----------计算返测高差
.Cells(i, 9) = (.Cells(i, 7) - .Cells(i, 8) + k2) * 1000
.Cells(i + 1, 9) = (.Cells(i + 1, 7) - .Cells(i + 1, 8) + k1) * 1000
Next i
For j = a + 5 To b Step 8
.Cells(j, 9) = (.Cells(j, 7) - .Cells(j, 8) + k1) * 1000
.Cells(j + 1, 9) = (.Cells(j + 1, 7) - .Cells(j + 1, 8) + k2) * 1000
Next j
ElseIf k = k2 Then
For i = 8 To a Step 8 '----------计算往测高差
.Cells(i, 9) = (.Cells(i, 7) - .Cells(i, 8) + k2) * 1000
.Cells(i + 1, 9) = (.Cells(i + 1, 7) - .Cells(i + 1, 8) + k1) * 1000
Next i
For j = 12 To a Step 8
.Cells(j, 9) = (.Cells(j, 7) - .Cells(j, 8) + k1) * 1000
.Cells(j + 1, 9) = (.Cells(j + 1, 7) - .Cells(j + 1, 8) + k2) * 1000
Next j
For i = a + 1 To b Step 8 '----------计算返测高差
.Cells(i, 9) = (.Cells(i, 7) - .Cells(i, 8) + k1) * 1000
.Cells(i + 1, 9) = (.Cells(i + 1, 7) - .Cells(i + 1, 8) + k2) * 1000
Next i
For j = a + 5 To b Step 8
.Cells(j, 9) = (.Cells(j, 7) - .Cells(j, 8) + k2) * 1000
.Cells(j + 1, 9) = (.Cells(j + 1, 7) - .Cells(j + 1, 8) + k1) * 1000
Next j
Else
MsgBox "请正确输入k的值"
End If
For i = 8 To a Step 4 '----------计算往测视距
If .Cells(i, 2) = "" Then GoTo lb1
.Cells(i + 2, 2) = (.Cells(i, 2) - .Cells(i + 1, 2)) * 1000 / 10
.Cells(i + 2, 4) = (.Cells(i, 4) - .Cells(i + 1, 4)) * 1000 / 10
.Cells(i + 3, 2) = (.Cells(i + 2, 2) - .Cells(i + 2, 4)) * 10 / 10
If i = 8 Then
.Cells(11, 4) = .Cells(11, 2)
Else
.Cells(i + 3, 4) = .Cells(i + 3, 2) + .Cells(i - 1, 4)
End If
.Cells(i + 2, 7) = (.Cells(i, 7) - .Cells(i + 1, 7)) * 1000 / 1000
.Cells(i + 2, 8) = (.Cells(i, 8) - .Cells(i + 1, 8)) * 1000 / 1000
.Cells(i + 2, 9) = (.Cells(i, 9) - .Cells(i + 1, 9)) * 1000 / 1000
.Cells(i + 2, 10) = .Cells(i + 2, 7) - .Cells(i + 2, 9) / 2000 '----------计算往测平均高差
Next i
For i = a + 1 To b Step 4 '----------计算返测视距
If .Cells(i, 2) = "" Then GoTo lb1
.Cells(i + 2, 2) = (.Cells(i, 2) - .Cells(i + 1, 2)) * 1000 / 10
.Cells(i + 2, 4) = (.Cells(i, 4) - .Cells(i + 1, 4)) * 1000 / 10
.Cells(i + 3, 2) = (.Cells(i + 2, 2) - .Cells(i + 2, 4)) * 10 / 10
If i = a + 1 Then
.Cells(i + 3, 4) = .Cells(i + 3, 2)
Else
.Cells(i + 3, 4) = .Cells(i + 3, 2) + .Cells(i - 1, 4)
End If
.Cells(i + 2, 7) = (.Cells(i, 7) - .Cells(i + 1, 7)) * 1000 / 1000
.Cells(i + 2, 8) = (.Cells(i, 8) - .Cells(i + 1, 8)) * 1000 / 1000
.Cells(i + 2, 9) = (.Cells(i, 9) - .Cells(i + 1, 9)) * 1000 / 1000
.Cells(i + 2, 10) = .Cells(i + 2, 7) - .Cells(i + 2, 9) / 2000 '----------计算返测平均高差
Next i
Dim sj, wsj, whj, wqj, fsj, fhj, fqj, clbhc, yxbhc As Single
For i = 8 To a Step 4 '-------------计算往测视距
whj = .Cells(i + 2, 2) + whj
wqj = .Cells(i + 2, 4) + wqj
Next i
wsj = whj + wqj
.Cells(b + 5, 2) = "往测："
.Cells(b + 5, 3) = "∑后距＝" & CStr(whj)
.Cells(b + 5, 6) = "∑前距＝" & CStr(wqj)
.Cells(b + 5, 9) = "总视距＝" & CStr(wsj)
For i = a + 1 To b Step 4 '-------------计算返测视距
fhj = .Cells(i + 2, 2) + fhj
fqj = .Cells(i + 2, 4) + fqj
Next i
fsj = fhj + fqj
.Cells(b + 6, 2) = "返测："
.Cells(b + 6, 3) = "∑后距＝" & CStr(fhj)
.Cells(b + 6, 6) = "∑前距＝" & CStr(fqj)
.Cells(b + 6, 9) = "总视距＝" & CStr(fsj)
sj = (wsj + fsj) / 1000 '-------------计算总视距
.Cells(b + 8, 2) = "L＝" & CStr(sj)
If sj < 1 Then '-------------计算允许闭合差
sj = 1
Else
sj = sj
End If
yxbhc = 12 * Sqr(sj)
For i = 10 To b Step 4 '-------------计算测量闭合差
clbhc = clbhc + .Cells(i, 10)
Next i
.Cells(b + 9, 2) = "测量闭合差△h＝" & clbhc & "mm"
.Cells(b + 10, 2) = "允许闭合差△h＝±" & yxbhc & "mm"
If clbhc < yxbhc Then
.Cells(b + 11, 2) = "测量合格"
Else
.Cells(b + 11, 2) = "测量不合格"
End If
.Cells(b + 4, 2) = "测量结果"
End With
lb1: xlBook.Close
xlApp.Quit
Set xlApp = Nothing
MsgBox "完成"
Unload Me
'Selection.NumberFormatLocal = "0.000_" '设定小数位数
End Sub
Sub chushihua()
On Error Resume Next
'Dim ColCount As Long, RowCount As Long
Dim xlApp As New Excel.Application
Dim xlBook As Excel.Workbook
Dim xlsheet As Excel.Worksheet
'Dim ArrTemp() As String
xlApp.Visible = False
Set xlBook = xlApp.Workbooks.Open(App.Path & "\three.XLS")
Set xlsheet = xlBook.Worksheets(1)
' ColCount = xlsheet.UsedRange.Cells.Columns.Count '得到总列
'RowCount = xlsheet.UsedRange.Cells.Rows.Count '得到总行
n = Val(Text2.Text)
If Not n Mod 2 = 0 Then
MsgBox ("请检查站数是否为偶数")
End
End If
On Error Resume Next
a = 7 + 4 * n
b = 7 + 8 * n
'c = a + 1
With xlsheet '设定小数位数
For i = 8 To b Step 4
.Range(Cells(i, 2), Cells(i + 1, 8)).Select
'ActiveCell.Formula = ""
Selection.NumberFormatLocal = "0.000_ "
.Range(Cells(i, 9), Cells(i + 2, 9)).Select
'ActiveCell.Formula = ""
Selection.NumberFormatLocal = "0_ "
.Range(Cells(i + 2, 2), Cells(i + 3, 4)).Select
'ActiveCell.Formula = ""
Selection.NumberFormatLocal = "0.0_ "
Next i
.Range(Cells(4, 1), Cells(b, 11)).Select '加边框
'.Range(Cells(i, 4), Cells(i, 5)).Select
Call Borders
Call wraptext '自动换行
.Range(Cells(1, 1), Cells(b, 11)).HorizontalAlignment = 3 '3居中 4右对齐 1 左对齐
'.Range("f8:f10").HorizontalAlignment = 4
.Range("a4:a7").MergeCells = True '------将工作表xlSheet中的B1与之间 的区域合拼。
.Range("a4:a7") = "仪器站号"
.Range("b4:b5").MergeCells = True
.Range("b4:b5") = "后尺"
.Range("b6:c6").MergeCells = True
.Range("b6:c6") = "后距"
.Range("b7:c7").MergeCells = True
.Range("b7:c7") = "视距差d"
.Range("c4") = "下丝"
.Range("c5") = "上丝"
.Range("d4:d5").MergeCells = True
.Range("d4:d5") = "前尺"
.Range("e4") = "下丝"
.Range("e5") = "上丝"
.Range("d6:e6").MergeCells = True
.Range("d6:e6") = "前距"
.Range("d7:e7").MergeCells = True
.Range("d7:e7") = "∑d"
.Range("f4:f7").MergeCells = True
.Range("f4:f7") = "方向及尺号"
.Range("g4:h5").MergeCells = True
.Range("g4:h5") = "水准尺读数"
.Range("g6:g7").MergeCells = True
.Range("g6:g7") = "黑面"
.Range("h6:h7").MergeCells = True
.Range("h6:h7") = "红面"
.Range("i4:i7").MergeCells = True
.Range("i4:i7") = "K+黑-红"
.Range("j4:j7").MergeCells = True
.Range("j4:j7") = "高差中数"
.Range("k4:k7").MergeCells = True
.Range("k4:k7") = "备注"
For i = 8 To b Step 4
.Cells(i, 6) = "后"
.Cells(i + 1, 6) = "前"
.Cells(i + 2, 6) = "后-前"
.Range(Cells(i, 2), Cells(i, 3)).Merge '-------------合并视距单元格
.Range(Cells(i + 1, 2), Cells(i + 1, 3)).Merge
.Range(Cells(i + 2, 2), Cells(i + 2, 3)).Merge
.Range(Cells(i + 3, 2), Cells(i + 3, 3)).Merge
.Range(Cells(i, 4), Cells(i, 5)).Merge
.Range(Cells(i + 1, 4), Cells(i + 1, 5)).Merge
.Range(Cells(i + 2, 4), Cells(i + 2, 5)).Merge
.Range(Cells(i + 3, 4), Cells(i + 3, 5)).Merge
.Range(Cells(i, 1), Cells(i + 3, 1)).Merge '-------------合并站号
Next i
For i = 8 To a Step 4 '-------------标站号
.Cells(i, 1) = i / 4 - 1
Next i
For i = a + 1 To b Step 4 '-------------标站号
If i = a + 1 Then
.Cells(a + 1, 1) = n
Else
.Cells(i, 1) = .Cells(i - 4, 1) - 1
End If
Next i
.Range(.Cells(b + 4, 2), Cells(b + 4, 10)).Merge
.Range(.Cells(b + 5, 3), Cells(b + 5, 4)).Merge
.Range(.Cells(b + 5, 6), Cells(b + 5, 7)).Merge
.Range(.Cells(b + 5, 9), Cells(b + 5, 10)).Merge
.Range(.Cells(b + 6, 3), Cells(b + 6, 4)).Merge
.Range(.Cells(b + 6, 6), Cells(b + 6, 7)).Merge
.Range(.Cells(b + 6, 9), Cells(b + 6, 10)).Merge
.Range(.Cells(b + 9, 2), Cells(b + 9, 11)).Merge
.Range(.Cells(b + 10, 2), Cells(b + 10, 11)).Merge
.Range(.Cells(b + 11, 2), Cells(b + 11, 11)).Merge
End With
xlBook.Close
xlApp.Quit
Set xlApp = Nothing
End Sub
Sub wraptext() '自动换行
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlCenter
.wraptext = True '自动换行
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
End Sub
Sub read() '读取excel内数据，并放到数组内
ReDim ArrTemp(ColCount, RowCount)
Dim k, kk As Long
For k = 1 To ColCount
For kk = 1 To RowCount
Debug.Print VarType(xlsheet.Cells(kk, k)) & " " & xlsheet.Cells(kk, k)
Select Case VarType(xlsheet.Cells(kk, k))
Case 0 '空
ArrTemp(k, kk) = "这是空的" '
Case 5 '数字型
ArrTemp(k, kk) = xlsheet.Cells(kk, k) '将所有信息放到ArrTemp这个数据中
Case 8 '字符型
ArrTemp(k, kk) = "这是字符" '
End Select
Next kk
Next k
MsgBox "完成"
End Sub
Sub Borders() '加边框
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft) '左边框
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop) '上边框
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom) '下边框
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight) '右边框
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideVertical) ' 内部垂直边框
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideHorizontal) ' 内部水平边框
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
End Sub
Private Sub Command2_Click()
Call chushihua
End Sub
就是不知道为什么excel表格里面有好多保存到小数后n位的，但小数点不应该有那么多0的，能直接减完的；而有的却没有，搞不明白。
有什么错误尽管提吧
r0bWDAY4.rar[此贴子已经被作者于2007-7-30 11:32:52编辑过]
