用Excel+VBA做一个工程量计算簿

开发环境：Microsoft Office 2010

适用环境：理论上应该适用于 Microsoft Office 2003 及以上的任意版本（或带 VBA 版的 WPS 软件）

本文代码使用方法：打开 VBA编辑界面，然后复制以下代码到工程对应的模块中，当你重新激活一个 "Sheet" 后，即可看到结果。此时，可以自由书写计算公式。

当然，怕看不懂代码，即使创建成功也不会用？没关系，我写了个使用说明，参见下图：

Option Explicit

Private Sub Workbook_Open()

    Application.OnKey "^{INSERT}", "插入行" Application.OnKey "^{DELETE}", "删除行" Application.OnKey "^g", "求和" Application.OnKey "^0", "启用事件捕捉" Run "启用事件捕捉" End Sub Private Sub Workbook_SheetActivate(ByVal Sh As Object) If Sh.Name = "Config" Then Exit Sub Run "初始化页面" End Sub Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range) If Sh.Name = "Config" Then Exit Sub If Target(1).Column > 7 Then Exit Sub On Error GoTo TheEnd Application.EnableEvents = False Application.ScreenUpdating = False Dim iHPageBreaks As Variant Dim i As Long, j As Long Dim iMaxRow As Long iMaxRow = ActiveSheet.UsedRange.Rows.Count If Target.Columns.Count > 8 Then Run "iBorderLine", Target(1).Row, iMaxRow - Target(1).Row For i = Target.Columns.Count To 1 Step -1 If i > 8 Then Exit Sub For j = 1 To Target.Rows.Count Step 1 Select Case Target(i).Column ' Case 1 ' ' Run "iCellCol1", Target(j).Row, Target.Rows.Count ' ' Case 2 ' ' Run "iCellCol2", Target(j).Row, Target.Rows.Count Case 4 Run "iCellCol4", Target(j).Row, Target.Rows.Count End Select Next Next TheEnd: Run "第一列补齐", Target(1).Row Application.ScreenUpdating = True Application.EnableEvents = True End Sub

ThisWorkBook

Option Explicit     '强制变量先声明后使用
Option Base 1 '数组维数从1开始 Private Sub 初始化页面() On Error Resume Next Application.StatusBar = "初始化页面..." Application.EnableEvents = False Application.ScreenUpdating = False Dim TitleArr As Variant TitleArr = Array("行号", "名称", "部位/代号", "计算式", "结果", "单位", "备注", "标记") With Cells(1, 1).Resize(1, 8) .Value = TitleArr .HorizontalAlignment = xlCenter .VerticalAlignment = xlBottom End With Dim i As Integer Dim w_arr As Variant w_arr = Array(4, 22, 12, 60, 10, 6, 16, 4) For i = 1 To UBound(w_arr) If Columns(i).ColumnWidth <> w_arr(i) Then Columns(i).ColumnWidth = w_arr(i) Next With Cells .RowHeight = 15 .Font.Name = "Consolas" .Font.Size = 11 End With Rows(1).RowHeight = 20 ActiveWindow.DisplayGridlines = False With ActiveWindow .SplitColumn = 1 .SplitRow = 1 .FreezePanes = True End With Application.StatusBar = "打印设置..." '将 PrintCommunication 属性设置为 False 将加速执行设置 PageSetup 属性的代码 '但是在Office2010中，执行此命令后，会有BUG 'Application.PrintCommunication = False With ActiveSheet.PageSetup .PrintTitleRows = "$1:$1" .PrintTitleColumns = "" .PageSetup.PrintArea = "" .LeftHeader = "&""宋体,加粗""&14&A " .CenterHeader = "" .RightHeader = "" .LeftFooter = "&""Consolas,倾斜""&11& <普通版>http://lnissi.cnblogs.com/" .CenterFooter = "" .RightFooter = "&""宋体,倾斜""&11& 工程量计算式[第&P页，共&N页]" .LeftMargin = Application.CentimetersToPoints(1.5) .RightMargin = Application.CentimetersToPoints(1) .TopMargin = Application.CentimetersToPoints(3) .BottomMargin = Application.CentimetersToPoints(1.5) .HeaderMargin = Application.CentimetersToPoints(2) .FooterMargin = Application.CentimetersToPoints(0.8) .PrintHeadings = False .PrintGridlines = False .PrintComments = xlPrintNoComments .PrintQuality = 600 .CenterHorizontally = True .CenterVertically = False .Orientation = xlLandscape .Draft = False .PaperSize = xlPaperA4 .FirstPageNumber = xlAutomatic .Order = xlDownThenOver .BlackAndWhite = False .Zoom = 100 .PrintErrors = xlPrintErrorsDisplayed .OddAndEvenPagesHeaderFooter = False .DifferentFirstPageHeaderFooter = False .ScaleWithDocHeaderFooter = True .AlignMarginsHeaderFooter = True End With 'Application.PrintCommunication = True  Application.StatusBar = "边框规则设置..." Cells.FormatConditions.Delete With Columns("A:A") .FormatConditions.Add Type:=xlExpression, Formula1:= _ "=AND(ROW()<>1,ROW()<=pLastLine)" .FormatConditions(.FormatConditions.Count).SetFirstPriority .FormatConditions(1).Borders(xlRight).Weight = xlThin .FormatConditions(1).StopIfTrue = False End With With Columns("A:H") .FormatConditions.Add Type:=xlExpression, Formula1:= _ "=ROW()=pLastLine" .FormatConditions(.FormatConditions.Count).SetFirstPriority .FormatConditions(1).Borders(xlBottom).Weight = xlThin .FormatConditions(1).StopIfTrue = False End With With Columns("D:F") .FormatConditions.Add Type:=xlExpression, Formula1:= _ "=AND(ROW()<>1,ROW()<>pLastLine,LEFT($D1,4)=""<Sum"")" .FormatConditions(.FormatConditions.Count).SetFirstPriority .FormatConditions(1).Borders(xlBottom).Weight = xlHairline .FormatConditions(

转载于:https://www.cnblogs.com/lnissi/p/9217277.html