EXCEL VBA测量平差程序1：绘制平差表格
1、我们常用的控制测量导线平差表如下图所示（以附合导线为例）：
2、要想用EXCEL VBA程序绘制导线平差表，需要先编写一个绘制单元格边框的程序，后面编写绘制表格程序时会调用这个程序。具体如下：
'绘制置单元格边框
Public Sub unitBorder()
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
End Sub
3、编写绘制导线平差表程序，主要应用了with语句，该程序根据测站数绘制表格，具体如下：
'绘制导线平差计算表
Public Sub DrawingTable1()
Sheets("Sheet1").Select
Dim ws As Worksheet
Dim rg As Range
Dim i As Integer
Dim j As Integer
Dim K As Integer
Dim n As Integer
Dim page As Integer '页数
Application.ScreenUpdating = False
'设置页面方向
Set ws = ThisWorkbook.Worksheets("sheet1")
With ws
.PageSetup.Orientation = xlLandscape
End With
'设置单元格居中
ws.Cells.Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
'设置页边距
ws.PageSetup.LeftMargin = Application.CentimetersToPoints(1.4)
ws.PageSetup.RightMargin = Application.CentimetersToPoints(0.9)
ws.PageSetup.TopMargin = Application.CentimetersToPoints(2)
ws.PageSetup.BottomMargin = Application.CentimetersToPoints(2)
'设置列宽
ws.Columns("A:A").ColumnWidth = 9: ws.Columns("B:B").ColumnWidth = 4
ws.Columns("C:C").ColumnWidth = 4: ws.Columns("D:D").ColumnWidth = 4
ws.Columns("E:E").ColumnWidth = 4: ws.Columns("F:F").ColumnWidth = 4
ws.Columns("G:G").ColumnWidth = 4: ws.Columns("H:H").ColumnWidth = 4
ws.Columns("I:I").ColumnWidth = 4: ws.Columns("J:J").ColumnWidth = 4
ws.Columns("K:K").ColumnWidth = 10: ws.Columns("L:L").ColumnWidth = 10
ws.Columns("M:M").ColumnWidth = 10: ws.Columns("N:N").ColumnWidth = 10
ws.Columns("O:O").ColumnWidth = 10: ws.Columns("P:P").ColumnWidth = 10
ws.Columns("Q:Q").ColumnWidth = 10
n = InputBox("请输入测站数:", "EXCEL VBA测量导线平常程序")
'设置行高
Set rg = ws.Rows: rg.RowHeight = 12
ws.Rows(1).RowHeight = 30: ws.Rows(2).RowHeight = 18
ws.Rows(3).RowHeight = 18: ws.Rows(3).RowHeight = 18
'合并单元格
Set ws = ThisWorkbook.Worksheets("sheet1")
ws.Range(Cells(2, 1), Cells(4, 1)).Merge (False)
ws.Range("A2").Value = "点号": Range(Cells(2, 1), Cells(4, 1)).Select: unitBorder
ws.Range(Cells(1, 1), Cells(1, 17)).Merge (False)
ws.Cells(1, 1).Value = "附 合 导 线 计 算 表"
ws.Cells(1, 1).Font.Size = 20
ws.Range(Cells(2, 2), Cells(2, 7)).Merge (False)
ws.Cells(2, 2).Value = "导线左角": Range(Cells(2, 2), Cells(2, 7)).Select: unitBorder
ws.Range(Cells(3, 2), Cells(3, 4)).Merge (False): ws.Cells(3, 2).Value = "观测角"
ws.Range(Cells(3, 5), Cells(3, 7)).Merge (False): ws.Cells(3, 5).Value = "改正后观测角"
ws.Cells(4, 2) = "°": ws.Cells(4, 3) = "′": ws.Cells(4, 4) = "″"
Range(Cells(3, 2), Cells(4, 4)).Select: unitBorder
ws.Cells(4, 5) = "°": ws.Cells(4, 6) = "′": ws.Cells(4, 7) = "″"
Range(Cells(3, 5), Cells(4, 7)).Select: unitBorder
ws.Range(Cells(2, 8), Cells(3, 10)).Merge (False): ws.Cells(2, 8).Value = "方位角"
ws.Cells(4, 8) = "°": ws.Cells(4, 9) = "′": ws.Cells(4, 10) = "″"
Range(Cells(2, 8), Cells(4, 10)).Select: unitBorder
ws.Range(Cells(2, 11), Cells(3, 11)).Merge (False)
ws.Cells(2, 11).Value = "边长S": ws.Cells(4, 11).Value = "m"
Range(Cells(2, 11), Cells(4, 11)).Select: unitBorder
ws.Range(Cells(2, 12), Cells(3, 13)).Merge (False)
ws.Cells(2, 12).Value = "增量计算": Range(Cells(2, 12), Cells(3, 13)).Select: unitBorder
ws.Cells(4, 12).Value = "△X(m)": ws.Cells(4, 13) = "△Y(m)"
Cells(4, 12).Select: unitBorder: Cells(4, 13).Select: unitBorder
ws.Range(Cells(2, 14), Cells(3, 15)).Merge (False)
ws.Cells(2, 14).Value = "改正后增量": Range(Cells(2, 14), Cells(3, 15)).Select: unitBorder
ws.Cells(4, 14).Value = "△X(m)": ws.Cells(4, 15) = "△Y(m)"
Cells(4, 14).Select: unitBorder: Cells(4, 15).Select: unitBorder
ws.Range(Cells(2, 16), Cells(3, 17)).Merge (False)
ws.Cells(2, 16).Value = "坐标": Range(Cells(2, 16), Cells(4, 17)).Select: unitBorder
ws.Cells(4, 16).Value = "X(m)": ws.Cells(4, 17) = "Y(m)"
Cells(4, 16).Select: unitBorder: Cells(4, 17).Select: unitBorder
For i = 6 To n * 2 + 6 Step 2
ws.Range(Cells(i, 1), Cells(i + 1, 1)).Merge (False)
ws.Range(Cells(i, 1), Cells(i + 1, 1)).Select: unitBorder
ws.Range(Cells(i + 1, 2), Cells(i + 1, 4)).Merge (False)
ws.Range(Cells(i, 2), Cells(i + 1, 4)).Select: unitBorder
ws.Range(Cells(i, 5), Cells(i + 1, 7)).Merge (False)
ws.Range(Cells(i, 5), Cells(i + 1, 7)).Select: unitBorder
ws.Range(Cells(i, 16), Cells(i + 1, 16)).Merge (False)
ws.Range(Cells(i, 16), Cells(i + 1, 16)).Select: unitBorder
ws.Range(Cells(i, 17), Cells(i + 1, 17)).Merge (False)
ws.Range(Cells(i, 17), Cells(i + 1, 17)).Select: unitBorder
Next
For i = 5 To n * 2 + 6 Step 2
ws.Range(Cells(i, 8), Cells(i + 1, 10)).Merge (False)
ws.Range(Cells(i, 8), Cells(i + 1, 10)).Select: unitBorder
ws.Range(Cells(i, 11), Cells(i + 1, 11)).Merge (False)
ws.Range(Cells(i, 11), Cells(i + 1, 11)).Select: unitBorder
ws.Range(Cells(i, 14), Cells(i + 1, 14)).Merge (False)
ws.Range(Cells(i, 14), Cells(i + 1, 14)).Select: unitBorder
ws.Range(Cells(i, 15), Cells(i + 1, 15)).Merge (False)
ws.Range(Cells(i, 15), Cells(i + 1, 15)).Select: unitBorder
ws.Range(Cells(i, 12), Cells(i + 1, 12)).Select: unitBorder
ws.Range(Cells(i, 13), Cells(i + 1, 13)).Select: unitBorder
Next
ws.Range(Cells(n * 2 + 7, 8), Cells(n * 2 + 7, 15)).Select: unitBorder
ws.Range(Cells(5, 1), Cells(5, 7)).Select: unitBorder
ws.Range(Cells(5, 16), Cells(5, 17)).Select: unitBorder
'***********************************************************
ThisWorkbook.Worksheets("sheet1").Range("s6").Value = "说明："
ThisWorkbook.Worksheets("sheet1").Range("s8").Value = "N="
ThisWorkbook.Worksheets("sheet1").Range("s10").Value = "∑β测="
ThisWorkbook.Worksheets("sheet1").Range("s12").Value = "α'=α始+∑β测-n×180(附合导线有）="
ThisWorkbook.Worksheets("sheet1").Range("s14").Value = "fβ="
ThisWorkbook.Worksheets("sheet1").Range("s22").Value = "边长和∑D="
ThisWorkbook.Worksheets("sheet1").Range("s24").Value = "增量和∑X="
ThisWorkbook.Worksheets("sheet1").Range("s26").Value = "增量和∑Y="
ThisWorkbook.Worksheets("sheet1").Range("s28").Value = "增量闭合差Fx="
ThisWorkbook.Worksheets("sheet1").Range("s30").Value = "增量闭合差Fy="
ThisWorkbook.Worksheets("sheet1").Range("s32").Value = "增量闭合差F="
ThisWorkbook.Worksheets("sheet1").Range("s34").Value = "精度K="
End Sub
4、运行程序
5、输入测站数。
6、程序在EXCEL中绘制出导线平差表，运行结果如下：
