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 WithEnd Sub

3、编写绘制导线平差表程序，主要应用了with语句，该程序根据测站数绘制表格，具体如下：'绘制导线平差计算表Public Sub 肛舀辨乔DrawingTable1() Sheets("Sheet1").SelectDim ws As WorksheetDim rg As RangeDim i As IntegerDim j As IntegerDim K As IntegerDim n As IntegerDim page As Integer '页数Application.ScreenUpdating = False'设置页面方向Set ws = ThisWorkbook.Worksheets("sheet1")With ws .PageSetup.Orientation = xlLandscapeEnd 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 = 4ws.Columns("C:C").ColumnWidth = 4: ws.Columns("D:D").ColumnWidth = 4ws.Columns("E:E").ColumnWidth = 4: ws.Columns("F:F").ColumnWidth = 4ws.Columns("G:G").ColumnWidth = 4: ws.Columns("H:H").ColumnWidth = 4ws.Columns("I:I").ColumnWidth = 4: ws.Columns("J:J").ColumnWidth = 4ws.Columns("K:K").ColumnWidth = 10: ws.Columns("L:L").ColumnWidth = 10ws.Columns("M:M").ColumnWidth = 10: ws.Columns("N:N").ColumnWidth = 10ws.Columns("O:O").ColumnWidth = 10: ws.Columns("P:P").ColumnWidth = 10ws.Columns("Q:Q").ColumnWidth = 10n = InputBox("请输入测站数:", "EXCEL VBA测量导线平常程序")'设置行高Set rg = ws.Rows: rg.RowHeight = 12ws.Rows(1).RowHeight = 30: ws.Rows(2).RowHeight = 18ws.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: unitBorderws.Range(Cells(1, 1), Cells(1, 17)).Merge (False)ws.Cells(1, 1).Value = "附 合 导 线 计 算 表"ws.Cells(1, 1).Font.Size = 20ws.Range(Cells(2, 2), Cells(2, 7)).Merge (False)ws.Cells(2, 2).Value = "导线左角": Range(Cells(2, 2), Cells(2, 7)).Select: unitBorderws.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: unitBorderws.Cells(4, 5) = "°": ws.Cells(4, 6) = "′": ws.Cells(4, 7) = "″"Range(Cells(3, 5), Cells(4, 7)).Select: unitBorderws.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: unitBorderws.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: unitBorderws.Range(Cells(2, 12), Cells(3, 13)).Merge (False)ws.Cells(2, 12).Value = "增量计算": Range(Cells(2, 12), Cells(3, 13)).Select: unitBorderws.Cells(4, 12).Value = "△X(m)": ws.Cells(4, 13) = "△Y(m)" Cells(4, 12).Select: unitBorder: Cells(4, 13).Select: unitBorderws.Range(Cells(2, 14), Cells(3, 15)).Merge (False)ws.Cells(2, 14).Value = "改正后增量": Range(Cells(2, 14), Cells(3, 15)).Select: unitBorderws.Cells(4, 14).Value = "△X(m)": ws.Cells(4, 15) = "△Y(m)" Cells(4, 14).Select: unitBorder: Cells(4, 15).Select: unitBorderws.Range(Cells(2, 16), Cells(3, 17)).Merge (False)ws.Cells(2, 16).Value = "坐标": Range(Cells(2, 16), Cells(4, 17)).Select: unitBorderws.Cells(4, 16).Value = "X(m)": ws.Cells(4, 17) = "Y(m)" Cells(4, 16).Select: unitBorder: Cells(4, 17).Select: unitBorderFor 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: unitBorderNextFor 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: unitBorderNextws.Range(Cells(n * 2 + 7, 8), Cells(n * 2 + 7, 15)).Select: unitBorderws.Range(Cells(5, 1), Cells(5, 7)).Select: unitBorderws.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中绘制出导线平差表，运行结果如下：