一个通用的EXCEL工程量计算表

cbtaja

再次更新求值函数：

1. Function XEVAL(ByVal exp As String) '作者cbtaja 2016-5-13
   
2.     If Len(exp) = 0 Then XEVAL = "": Exit Function
   
3.     exp = ExpClean(exp)
   
4.     If Len(exp) = 0 Then XEVAL = "": Exit Function
   
5.     If Len(Replace(exp, "(", "")) - Len(Replace(exp, ")", "")) Then XEVAL = "括号不成对": Exit Function
   
6.     XEVAL = mEval(exp) '对Exp分步计算，可以应对超长的Exp计算式
   
7. '    XEVAL = Evaluate(exp)'如果exp的长度总是不超过255，则可以用Evaluate简化计算过程。
   
8. '    If IsError(XEVAL) Then XEVAL = EvalErrInfo(CStr(XEVAL)) & Exp
   
9. End Function
   
10. 
    
11. Function EvalErrInfo(ByVal exp As String)
    
12.     Select Case CStr(exp)
    
13.         Case "Error 2000": EvalErrInfo = "缺少参数："
    
14.         Case "Error 2007": EvalErrInfo = "除数为○："
    
15.         Case "Error 2015": EvalErrInfo = "参数类型不符："
    
16.         Case "Error 2023": EvalErrInfo = "单元格引用无效："
    
17.         Case "Error 2029": EvalErrInfo = "函数名无效："
    
18.         Case "Error 2036": EvalErrInfo = "参数超出范围："
    
19.         Case "Error 2042": EvalErrInfo = "参数无效："
    
20.         Case Else:
    
21.     End Select
    
22. End Function
    
23. 
    
24. Function ExpClean$(ByVal exp As String)
    
25.     Set reg = CreateObject("VBScript.RegExp")
    
26.     reg.Global = True
    
27.     reg.Pattern = "\[[^\]\[]*\]" '忽略计算式中的[注释内容]
    
28.     exp = reg.Replace(exp, "")
    
29.     a = [{"＋","+";"－","-";"×","*";"÷","/";"（","(";"）",")";"%","*0.01"}] '“兼容”中文数学运算符'
    
30.     For i = 1 To UBound(a)
    
31.         reg.Pattern = a(i, 1)
    
32.         exp = reg.Replace(exp, a(i, 2))
    
33.     Next
    
34.     If InStr(exp, "[") Or InStr(exp, "]") Then ExpClean = "[]不成对": Exit Function
    
35.     reg.Pattern = "[^\x20-\x7e]+" '仅保留“基本拉丁字符”
    
36.     ExpClean = reg.Replace(exp, "")
    
37. End Function
    
38. 
    
39. Function sEval(ByVal exp As String)
    
40.     exp = UCase(exp)
    
41.     Set reg = CreateObject("VBScript.RegExp")
    
42.     reg.Global = False
    
43.     sPttnNumber = "\d+(\.\d+){0,1}(E[+-]\d+(\.\d+){0,1}){0,1}" '数值（含整数、小数、科学计数法表示的数值）
    
44.     sPttnCalChar = [{"\^","[\*\/]","[\+\-]"}] '依次进行乘幂、乘除、加减运算
    
45.     For i = 1 To UBound(sPttnCalChar)
    
46.         reg.Pattern = "(?:\b)" & sPttnNumber & sPttnCalChar(i) & sPttnNumber
    
47.         Do While reg.test(exp)
    
48.             Set matches = reg.Execute(exp)
    
49.             tmp = matches(0)
    
50.             sEval = Evaluate(tmp)
    
51.             If IsError(sEval) Then sEval = EvalErrInfo(CStr(sEval)) & tmp: Exit Function
    
52.             exp = reg.Replace(exp, sEval)
    
53.             If Len(exp) <= 255 Then Exit Do
    
54.         Loop
    
55.     Next
    
56.    
    
57.     'Evaluate("1") 无法计算，所以按条件处理为两次求反
    
58.     If Len(exp) = 1 Then sEval = Evaluate("--" & exp) Else sEval = Evaluate(exp)
    
59.    
    
60.     If IsError(sEval) Then sEval = EvalErrInfo(CStr(sEval)) & exp
    
61. End Function
    
62. 
    
63. Function mEval(ByVal exp As String)
    
64.     Set reg = CreateObject("VBScript.RegExp")
    
65.     reg.Global = True
    
66.     reg.Pattern = "\w+(\([^\(\)]*\))"
    
67.     Do While reg.test(exp)
    
68.         Set matches = reg.Execute(exp)
    
69.         For i = matches.Count To 1 Step -1
    
70.             mEval = sEval(matches(i - 1).Value)
    
71.             If Not IsNumeric(mEval) Then Exit Function
    
72.             exp = reg.Replace(exp, mEval)
    
73.         Next
    
74.     Loop
    
75.     mEval = sEval(exp)
    
76. End Function
    
77. 
    
78. Function XEval(ByVal Exp As String) '作者cbtaja 2016-5-13
    
79.     '自动转换中文运算符＋－×÷
    
80.     '允许百分号%和科学计数符号e
    
81.     '允许数学函数（要以前缀m.或Math.作标记，注意名称和参数类型要正确）
    
82.     '允许中文直接注释，
    
83.     '允许用成对中括号（即[]）包含任意注释字符，
    
84.     '剩余不成对的中括号"["、"]"将被忽略
    
85.     '最后，如果算式仍无法计算，则报告出错的变量
    
86.     '------------------------------------------------
    
87.     Dim oJs As Object, XX As String, errinfo, a, i&
    
88.     Set oJs = CreateObject("ScriptControl")
    
89.     oJs.Language = "JScript"
    
90.     Exp = oJs.eval("'" & Exp & "'.replace(/\[[^\]\[]*\]/g,"""")") '清除成对中括号[]及其中的内容
    
91.     If IsEmpty(Exp) Then Exit Function
    
92.    
    
93.     a = [{"＋","+";"－","-";"×","*";"÷","/";"[","";"]","";"%","*0.01"}] '替换不规范的运算符
    
94.     For i = 1 To UBound(a)
    
95.         Exp = Replace(Exp, a(i, 1), a(i, 2))
    
96.     Next
    
97.     If IsEmpty(Exp) Then Exit Function
    
98.    
    
99.     Exp = oJs.eval("'" & Exp & "'.replace(/[^\x21-\x7e]/g,"""")") '仅保留ASC码为33至125之间的字符
    
100.     If IsEmpty(Exp) Then Exit Function
     
101.    
     
102.     Exp = oJs.eval("'" & Exp & "'.replace(/\bm\./ig,""Math."")") '把“m.”(或“M.”)替换为“Math.”，以支持Js的数学函数
     
103.     If IsEmpty(Exp) Then Exit Function
     
104.    
     
105.     On Error GoTo errhdl
     
106.     XEval = oJs.eval(Exp) '对经过整理后的计算式进行求值
     
107.     If IsEmpty(XEval) Then GoTo errhdl
     
108.     XX = CStr(XEval)
     
109.    
     
110.     For Each errinfo In Array("R", "IND", "INF", "QNAN", "SNAN")
     
111.         If InStr(XX, ".#" & errinfo) Then GoTo errhdl
     
112.     Next
     
113.     Exit Function
     
114. errhdl:
     
115.     XEval = "请修正:" & Trim(oJs.eval("'" & Exp & "'.replace(/[^\w.\/]+/ig,"""")"))
     
116. End Function

复制代码

用JSCript的EVAL方法，也可以做很多事情：

1. Function ev(ByVal s As String)
   
2.     Set oJs = CreateObject("ScriptControl")
   
3.     oJs.Language = "JScript"
   
4.     ev = oJs.eval(s)
   
5. End Function
   
6. Private Sub cs()
   
7. Dim sss(0 To 9)
   
8. sss(0) = "(2,Math.PI/2)"
   
9. sss(1) = "小黄的数学考试得了95分，评价为A；语文得了92分，评价为B+，他的父亲奖励了他一双价值888.88元的轮滑鞋。"
   
10. sss(2) = "2+Math.sin(Math.PI/4)"
    
11. aaa = ev(sss(0)) '数学函数式求值
    
12. MsgBox aaa
    
13. aaa = ev("'" & sss(1) & "'.replace(/[\s\u3400-\ufe4f]+/ig,"" "")") '文本正则替换
    
14. MsgBox aaa
    
15. aaa = ev(sss(2)) '数学函数式求值
    
16. MsgBox aaa
    
17. aaa = ev("'" & sss(1) & "'.length") '求字符串长度
    
18. MsgBox aaa
    
19. aaa = ev("'" & sss(1) & "'.substr(3,9)") '取子符串（类似于VB的mid函数)
    
20. MsgBox aaa
    
21. aaa = ev("Math.e") '
    
22. MsgBox aaa
    
23. aaa = ev("Math.E") '自然对数的底E。要注意：Script中的变量名是区分大小写的。
    
24. MsgBox aaa
    
25. '通过构造语句，以JSCript的EVAL方法解释执行语句，可以完成很多事情。（只要熟知JSCript的内置对象的属性、方法、函数就好办）
    
26. Stop
    
27. End Sub

复制代码

1. Function RegReplace(ByVal s As String, ByVal patn As String, Optional ByVal delemit As String = "")
   
2.     '中文："[\u3400-\ufe4f]"
   
3.     '数字："[\d]"或"[0-9]"
   
4.     '数值："\d+(\.\d+|)(e[+-]\d+)?%?"
   
5.     '字母："[a-zA-Z]"
   
6.     Set reg = CreateObject("vbscript.Regexp")
   
7.     reg.Global = True
   
8.     reg.Pattern = patn
   
9.     RegReplace = reg.Replace(s, delemit)
   
10. End Function

复制代码

补充内容 (2016-7-4 21:47):
求值函数更新，修正1处Bug，请从23楼下载附件中查看。

cbtaja

更新内容：2016-5-22
1、更新计算式求值函数：①突破255字符数上限限制，②可在64位EXCEL中正常运行，③、当计算式不能计算出结果时，提示信息更加全面：可以精确提示错误发生的部位和原因！
2、“代号”输入或计算其计算式时，自动检测并提示命名不合格的“代号”。
3、汇总计算时自动检测提示重复的代号名称。
4、增加对所有自动宏的开关（当不需要自动提示或计算功能时，可以关闭自动宏，专注于表格数据输入，且可避免自动宏影响撤消功能。）
5、自动汇总，取消原来的VBA+数据透视表方式，采用VBA数组+字典方式，运算更快速、所得汇总表的版面也更整洁。
如使用64位EXCEL，类模块中的代码需要替换如下部分API声明：

1. Private Declare PtrSafe Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" _
   
2.         (Destination As Any, Source As Any, ByVal Length As Long)
   
3.         
   
4. Private Declare PtrSafe Function CLSIDFromString Lib "ole32.dll" _
   
5.         (ByVal lpszProgID As Long, pCLSID As GUID) As Long
   
6.         
   
7. Private Declare PtrSafe Function CoCreateInstance Lib "ole32" ( _
   
8.         rclsid As GUID, ByVal pUnkOuter As Long, _
   
9.         ByVal dwClsContext As Long, riid As GUID, _
   
10.         ByRef ppv As Long) As Long
    
11. 
    
12. Private Declare PtrSafe Function DispCallFunc Lib "oleaut32" _
    
13.         (ByVal pvInstance As Long, ByVal oVft As Long, _
    
14.         ByVal cc As Long, ByVal vtReturn As Integer, _
    
15.         ByVal cActuals As Long, prgvt As Integer, _
    
16.         prgpvarg As Long, pvargResult As Variant) As Long
    
17. 
    
18. Private Declare PtrSafe Sub CoTaskMemFree Lib "ole32" (pv As Long)

复制代码

蟋蟀的帅

支持楼主，学习一下。

love3456

太棒了！谢谢楼主的分享！

cbtaja

工程量计算表.rar (580.19 KB, 下载次数: 306)

2016-7-19 19:03 上传

点击文件名下载附件

1、更新计算式自动求值函数：

      ①、完美支持EXCEL所有内置函数及当前可用的自定义函数；
      ②、支持用【代号】引用计算式结果的功能；
      ③、支持单元格引用；
      ④、注释内容可自动突出显示：即可自动下标且变色。且该功能可随时开关。注释内容的分析更加精准：被成对引号包含的内容，被优先解释为公式中的“字符串”常量参数，终于可以如同EXCEL公式一样地能正确计算出 Text(Day(today())-11,"[>9]下旬;上旬;中旬") 这样的算式了！

现在可以算是几乎完全达成开贴时的几个目标了:
1、计算式自动求值，可包含注释，且注释可自动地以下标形式突出显示；
2、计算式支持用“代号”引用计算结果；
3、在输入分项名称时，能自动匹配内置小型的（定额）数据库，并能 逐步提示 + 自动完成，以人为本的完美体验；
4、对工程量清单实现一键自动汇总功能；
5、计算稿和汇总表的表格边框都可自动添加或消除，省去手工设置的麻烦
6、预设了合理的页面设置，其中默认打印表格行号列标，这样当在计算式中直接引用单元格名称时，可以直观对应相应的数值，比自己编写代号更灵活。

        最后，如果还有兴趣继续的话，可能考虑的升级方向有：
        1、增加对常见特殊形状或结构的工程量计算公式的图形化辅助输入，可方便土建的混凝土、土方、沟渠等体积计量，装饰、粉刷、油漆等面积计量，钢筋等长度计量，以及安装工程中电缆、管线、钢结构等的主材用量计算公式；另外，可考虑由用户自行扩充该图形辅助公式库的功能；
        2、把EXCEL内置定额库可改为外部ACCESS数据库，可减少模板文件体积，方便更换定额。
        如果再完成这些的话，基本上就达到表格算量软件其所能提供的帮助的极限了。
       现在四维算量软件普及化，但表格算量仍以其灵活性、对数据本身的直接操作和结果呈现形式而占有相当份额的市场。而且，相对于工程预算员的人数，工程施工技术员的人数更多。后者在做材料计划时，所使用的一般不会是各种图形算量软件，而往往是自己所熟练操作的电子表格软件。本表格模板也算是一个小小的贡献吧

LG1616

下载了,试了一下,输入计算式没见反应,还是我不会用

kfhgng

楼主 能不能有在win10系统64位下可用的，谢谢！

cbtaja

kfhgng 发表于 2016-8-26 16:12
楼主 能不能有在win10系统64位下可用的，谢谢！

25楼的附件，可以在64位和32位的excel中通用的，只需要启用宏即可。至于26楼所说，输入计算式后没有反应，可能是在程序的“批量设置”中关闭了“启用自动宏”功能，只需要执行“批量设置”宏，勾选“启用自动宏”即可。

d346836673

收下了 谢谢分享！

妙风

楼主，对于撤销功能失效的问题可以解决吗？