用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(1).StopIfTrue = False .FormatConditions.Add Type:=xlExpression, Formula1:= _ "=AND(ROW()<>1,ROW()<>pLastLine,$B1<>"""",OFFSET($B1,1,0)<>"""")" .FormatConditions(.FormatConditions.Count).SetFirstPriority .FormatConditions(1).Borders(xlBottom).Weight = xlHairline .FormatConditions(1).StopIfTrue = False End With Application.StatusBar = "" Application.ScreenUpdating = True Application.EnableEvents = True End Sub Private Sub 第一列补齐(ByVal iRow As Long) Dim i As Long Dim j As Long j = iRow - 2 + 29 - (iRow - 2) Mod 29 For i = j / 29 To j Step 1 Cells(i + 1, 1).Value = i Next End Sub Private Sub 启用事件捕捉() Application.EnableEvents = True Application.ScreenUpdating = True End Sub Private Sub 求和() If ActiveSheet.Name = "Config" Then Exit Sub Application.EnableEvents = False On Error GoTo TheEnd Dim mCell As Range Set mCell = Application.InputBox(prompt:="请选择需要汇总的单元格", Title:="汇总选择", Default:=Selection.Address, Type:=8) With mCell(mCell.Count).Offset(1, 0) If .Offset(0, -3).Value <> "" Or .Value <> "" Then If MsgBox("是否覆盖" & .Address, vbYesNo, "温馨提示") = vbNo Then .EntireRow.Insert With .Offset(-1, 0) .Formula = "=SUMIF(" + mCell.Offset(0, 1).Address + "," + .Offset(-1, 1).Address + "," + mCell.Address + ")" .NumberFormatLocal = "0.00_ ;[红色]-0.00_ " .Offset(0, -1).Value = "<Summary Row> - R" & mCell(1).Row - 1 & " to R" & mCell(mCell.Count).Row - 1 End With GoTo TheEnd End If End If .Formula = "=SUMIF(" + mCell.Offset(0, 1).Address + "," + .Offset(0, 1).Address + "," + mCell.Address + ")" .NumberFormatLocal = "0.00_ ;[红色]-0.00_ " .Offset(0, -1).Value = "<Summary Row> - R" & mCell(1).Row - 1 & " to R" & mCell(mCell.Count).Row - 1 End With TheEnd: Application.EnableEvents = True End Sub Private Sub 插入行() Application.EnableEvents = False Application.ScreenUpdating = False On Error GoTo TheEnd Dim i As Long, bRow As Long, cRow As Long bRow = Selection(1).Row If bRow = 1 Then bRow = bRow + 1 cRow = Selection.Rows.Count For i = 1 To cRow Step 1 Rows(bRow).Insert Next TheEnd: Application.ScreenUpdating = True Application.EnableEvents = True End Sub Private Sub 删除行() Application.EnableEvents = False Application.ScreenUpdating = False On Error GoTo TheEnd Dim i As Long For i = Selection.Rows.Count To 1 Step -1 Rows(Selection(i).Row).Delete Next TheEnd: Application.EnableEvents = True Application.ScreenUpdating = True End Sub 'Private Sub SetFormat() ' .WrapText = False '不要自动换行 ' .ShrinkToFit = True '缩小字体填充 ' .HorizontalAlignment = xlLeft '水平向右 ' .VerticalAlignment = xlBottom '垂直向下 'End Sub Private Sub RefreshName(ByVal strName As String) On Error Resume Next Dim iRow As Long Select Case strName Case "MaxRow" ActiveSheet.Names.Add Name:="MaxRow", RefersToR1C1:="=" & ActiveSheet.UsedRange.Rows.Count, Visible:=False End Select End Sub Private Sub ce() Run "refreshname", "MaxRow" End Sub

模块1

Option Explicit
Option Base 1

Private Function readName(ByVal strName As String) On Error Resume Next readName = Evaluate(ActiveSheet.Names(strName).RefersTo) End Function Public Function iJS(ByVal str As String, Optional ByVal num As Integer = 2) On Error Resume Next Dim oRegExp As New RegExp With oRegExp .Global = True .IgnoreCase = True .Pattern = "\d+" If (Not .Test(str)) Then '如果测试到单元格没有数字 iJS = "" 'iJS返回空 Exit Function '退出函数 End If .Pattern = "\s|\[.*?\]|[\u2E80-\u9FFF]*|[\u3000-\u301e\ufe10-\ufe19\ufe30-\ufe44\ufe50-\ufe6b\uff01-\uffee]*" str = .Replace(str, "") .Pattern = "[a-zA-Z]" str = .Replace(str, "") .Pattern = "＋" str = .Replace(str, "+") .Pattern = "－" str = .Replace(str, "-") .Pattern = "×" str = .Replace(str, "*") .Pattern = "÷" str = .Replace(str, "/") .Pattern = "([\+\-\*/])(\1*)" str = .Replace(str, "$1") End With Set oRegExp = Nothing iJS = WorksheetFunction.Round(Evaluate(str), num) End Function

模块2

Option Explicit
Option Base 1

Private Sub iCellCol4(ByVal iRow As Long, Optional ByVal iCount As Long = 1) On Error Resume Next Dim i As Long For i = 1 To iCount Step 1 If iRow + i - 1 = 1 Then Exit For With Cells(iRow + i - 1, 4) If .Value = "" Then .Offset(0, 1).Value = "": Exit For '水平靠左 .HorizontalAlignment = xlLeft '垂直靠下 .VerticalAlignment = xlBottom If Left(.Value, 13) <> "<Summary Row>" Then .Offset(0, 1).Value = iJS(.Value) .Offset(0, 1).NumberFormatLocal = "0.00_ ;[红色]-0.00_ " End If End With Next End Sub

模块3

呃，已经好久没写文章，都不知道该如何描述了，就这样吧。