解决Evaluate函数超过255字符的方法之一

岁月无恒 · 发表于 2017-11-25 02:51

本帖最后由岁月无恒于 2017-11-27 15:10 编辑

EVALUATE宏表函数，是表达式计算的最常用函数之一，此函数功能强大，支持excel内置函数、支持分行计算、使用方便，表达式计算的首选函数。
但是，这个函数存在表达式字符的长度限制，超过255个字符。计算结果就会显示错误，导致无法使用。论坛里提供过其他的解决方法，或多或少存在些缺陷，比如使用不方便、需要库的支持、不支持excel内置函数等等。
我提供的方案，或许是最笨的方法，实现了我工作使用的要求，不受字符长度限制、可以用内置函数等，解决方案为：利用四则混合运算法则，把字符数超过限制的表达式（使用EVALUATE函数），先进行运算级别最高的括号运算→用计算结果生成新的没有括号的表达式→再把除加减外的运算全部计算（加减的运算级别最低留最后，乘除、乘方的计算顺序，由excel自己判断，我只把相关计算式提取出来）→再把运算结果重新生成只有加减运算的表达式→最后使用EVALUATE函数输出表达式结果，这样就间接的减少了表达式的长度，实现了计算要求。
代码写得不够精简，请各位见谅，如有需要，欢迎使用。使用中出现了问题，请及时留言反馈。

测试.rar (16.22 KB, 下载次数: 159)

Function MyVlaue(Rng As Range, Optional Point As Integer = 3) As Variant
Dim 计算式 As String, Tmp As String
'=====================================计算式整理=====================================
'计算式中可以用中括号、大括号，使计算式更为直观，以便做检查计算式
Tmp = Application.Clean(StrConv(Rng, vbNarrow)) '全角转半角,清不可见字符
Tmp = Application.Substitute(Tmp, , ) '清除计算式中的空格
Tmp = Replace(Replace(Tmp, （, (), ）, )) '中文括号转换为英文括号
Tmp = Replace(Replace(Tmp, [, (), ], )) '中括号转换为小括号
Tmp = Replace(Replace(Tmp, {, (), }, )) '大括号转换为小括号
Tmp = Replace(Replace(Tmp, ×, ), ÷, ) '乘号、除号转换为计算符号
'===================================清除计算式的注释===================================
'注释内容一定要用【】标记，否侧会影响后面的判断
Dim i As Integer, j As Integer
For j = 1 To Len(Tmp)
If Mid(Tmp, j, 1) = 【 Then
For i = j + 1 To Len(Tmp)
If Mid(Tmp, i, 1) = 】 Then
j = i + 1
Exit For
End If
Next
End If
计算式 = 计算式 & Mid(Tmp, j, 1)
Next
'======================================整理式计算======================================
'如果计算式长度少于等于255字符，则跳过此步，直接进结果计算
'如果计算式长度大于255字符，则按照四则运算法则：函数公式→括号→乘除→加减顺序
'如果计算式中存在函数，函数的括号会影响括号的计算，需要先把函数公式转换成结果
'再判断“＋”、“－”号的位置，把相邻“＋”、“－”号之间的计算式（乘除等运算）转换为结果
'判断得到的纯加减运算式的长度，若小于等于255字符，直接结算结果；若大于于255字符，再进行简化
If Len(计算式) > 255 Then '如果计算式字符数小于等于255，则跳过此步
'先把公式中引用的定义名称转换成数值，以免名称中的字母影响函数的判断
Dim Na, s As Integer
Set Na = ActiveWorkbook.Names
For s = 1 To Na.Count
If InStr(计算式, Na(s).Name) 0 Then
计算式 = Application.Substitute(计算式, Na(s).Name, Evaluate(Na(s).Name))
End If
Next
'判断计算式中是否存在函数，若存在，先依次计算函数（以免函数中的括号影响下一步括号计算）
Dim TmpStr1$, TmpValue1 As Double
Dim a%, b%, c%, d%, e% '计数器
For a = 1 To Len(计算式) - 2
If Mid(计算式, a, 1) Like [A-Z] Or Mid(计算式, a, 1) Like [a-z] Then '出现字母，表示出现了函数
'判断函数嵌套了几层
Do
b = b + 1
If Mid(计算式, a + b, 1) = ( Then
c = c + 1
End If
Loop Until Mid(计算式, a + b, 1) = ) Or InStr(+-, Mid(计算式, a + b, 1)) 0
'计算函数结束位置
Do
d = d + 1
If Mid(计算式, a + d, 1) = ) Then
e = e + 1
End If
Loop Until e = c
'提取函数公式部分计算式
TmpStr1 = Mid(计算式, a, d + 1)
TmpValue1 = Evaluate(TmpStr1)
计算式 = Application.Substitute(计算式, TmpStr1, TmpValue1) '把函数结果写入计算式
b = 0 c = 0 d = 0 e = 0 '计数器归零，以便下次使用
End If
Next
'如果有括号，先计算括号内的内容
If VBA.InStr(计算式, () 0 Then
Dim TmpValue2 As Double, TmpStr2$
Dim KaiShi%, JieShu%, ShuLiang%
Do
JieShu = VBA.InStr(计算式, ))
ShuLiang = Len(Mid(计算式, 1, JieShu)) - Len(Application.Substitute(Mid(计算式, 1, JieShu), (, ))
KaiShi = InStr(Application.Substitute(Mid(计算式, 1, JieShu), (, @, ShuLiang), @)
TmpStr2 = Mid(计算式, KaiShi, JieShu - KaiShi + 1)
TmpValue2 = Evaluate(TmpStr2)
计算式 = Application.Substitute(计算式, TmpStr2, TmpValue2) '把括号结果写入计算式
Loop Until InStr(计算式, )) = 0
End If
'如果有乘除，再从左往右依次算乘除
If VBA.InStr(计算式, ) + VBA.InStr(计算式, ) 0 Then
Dim TmpValue3 As Double, TmpStr3$, Str3$
Dim x%, y%, z%
Dim Arr(1 To 1000)
Arr(1) = 0
For x = 1 To Len(计算式)
If InStr(+-, Mid(计算式, x, 1)) 0 Then
y = y + 1
Arr(y + 1) = x
End If
Next
Arr(y + 2) = Len(计算式)
For z = 1 To y + 1
If z = 1 Then
TmpStr3 = Mid(计算式, Arr(z) + 1, Arr(z + 1) - 1)
ElseIf z = y Then
TmpStr3 = Mid(计算式, Arr(z) + 1, Arr(z + 1) - Arr(z) - 1)
ElseIf z = y + 1 Then
TmpStr3 = Mid(计算式, Arr(z) + 1, Arr(z + 1) - Arr(z))
TmpValue3 = Evaluate(TmpStr3)
Str3 = Str3 & TmpValue3
Exit For
End If
TmpValue3 = Evaluate(TmpStr3)
Str3 = Str3 & TmpValue3 & Mid(计算式, Arr(z + 1), 1)
Next
计算式 = Str3 '更新计算式
End If
'若最后得到的计算式仍大于255字符，再进行简化，直到长度小于等于255字符
Dim TmpStr4$, TmpVlaue4 As Double
Dim m%, n%
If Len(计算式) > 255 Then
Do
Do
m = m + 1
Loop Until InStr(+-, Mid(计算式, 255 - m, 1)) 0
TmpStr4 = Mid(计算式, 1, 255 - m - 1)
TmpValue4 = Evaluate(TmpStr4)
计算式 = Application.Substitute(计算式, TmpStr4, TmpValue4)
m = 0
Loop Until Len(计算式) <= 255
End If
End If
'=======================================计算结果=======================================
'如果计算式为空，则结果也为空
'如果计算式有问题，计算结果显示“错”
If Len(计算式) = 0 Then
MyVlaue =
ElseIf VBA.IsError(Application.Evaluate(( & 计算式 & ))) Then '若计算式有误，结果为错
MyVlaue = 错
Else
MyVlaue = Application.Round(Application.Evaluate(( & 计算式 & )), Point)
End If
End Function

复制代码

Zamyi · 发表于 2017-11-25 08:45

很简单，（1+2+...+100）就出错。现成的：

Function F(S)
With CreateObject("MSScriptControl.ScriptControl")
.Language = "vbscript"
F = .Eval(S)
End With
End Function

复制代码

岁月无恒 · 发表于 2017-11-25 12:22

本帖最后由岁月无恒于 2017-11-25 13:30 编辑

Zamyi 发表于 2017-11-25 08:45
很简单，（1+2+...+100）就出错。现成的：

计算式中需要添加备注信息，这个确实可以不受字符数的限制，但是无法添加我要的备注信息。计算式比较长的时候，我要手动分行，手动分行后，这个函数也无法计算。
QQ截图20171125122214.jpg

[309411] · 发表于 2018-5-16 18:55

挺好用的，暂时没发现BUG。优化版的有么，大哥？

[309411] · 发表于 2018-5-17 14:37

1+1【备注1】【备注2】，这样有2个备注的时候就会出错

[309411] · 发表于 2018-5-17 14:53

1+1【备注】】显示错
1+1【【备注】就能计算

34682189 · 发表于 2018-5-18 16:39

楼主的去备注文字代码有误，重新代码如下：
'替换掉计算式中的[说明]
Do
If UBound(Split(jss, "[")) <> UBound(Split(jss, "]")) Then YJS = "括号错误": Exit Function
If InStr(jss, "[") > InStr(jss, "]") Then YJS = "括号错误": Exit Function
If InStr(jss, "[") = 0 Then Exit Do
jss = Left(jss, InStr(jss, "[") - 1) & Right(jss, Len(jss) - InStr(jss, "]"))
If InStr(jss, "]") = 0 Then Exit Do
Loop

34682189 · 发表于 2018-5-18 16:44

很好的思路，正是我想要的。解决了我的一个问题。
http://club.excelhome.net/thread-1375312-1-1.html

34682189 · 发表于 2018-5-18 17:43

不完美，有缺陷。不能计算max(超长计算式,超长计算式)这类内置函数

岁月无恒 · 发表于 2018-5-24 08:50

34682189 发表于 2018-5-18 16:39
楼主的去备注文字代码有误，重新代码如下：
'替换掉计算式中的[说明]
Do

谢谢提醒，我再测试下。

		自动登录	找回密码
密码			免费注册

[分享] 解决Evaluate函数超过255字符的方法之一

评分