四则混合运算计算式计算的纯VBA代码

shaoshan

我们在工作中有时候要遇到计算某个单元格中表达式的结果,如A1中有一表达式(36.25+23.6)*3-6,现要在A2中计算出A1的结果,我们一般有好几种方法:

1.利用内部插入函数evaluate计算.注:此函数能在插入名称定义中使用,也可以在VBA代码中使用,但不能在工作表中直接调用.

2.利用VBA编写一段代码 通过eval(A1)来计算出结果,但此方法需我们加载Access库.

3.以上两种方法都有其缺陷,第1种方法有字符限制,当你的表达式超出255时,Excel会崩溃.而第2种方法必须加载Access库,如果你电脑上没有安装哪就不能用.所以我通过分析上述两种方法,编写了一个无需外挂的函数(AdvanceJS1),突破了255字符限制.并且代码没有我当初想象中那么长,呵~~请大家多多指教.此程序还可以扩展,实现计算所有内部函数的功能.

Option Explicit
Private ExpArray() As String

Private Function CustomCalculate(x As String)
ExpressionArray (x)
Call RemoveSign("*", "/")
Call RemoveSign("+", "-")
Dim i As Variant
For Each i In ExpArray
If i <> "&" Then CustomCalculate = Val(i)
Next i
End Function

Private Function ExpressionArray(Expn As String)
Dim length_x As Integer
Dim i As Integer
Dim ExpArray_bound As Integer
Dim indexp As Integer
Erase ExpArray
length_x = Len(Expn)
ExpArray_bound = 0
indexp = 1
For i = 1 To length_x
        If Asc(Mid(Expn, i, 1)) >= 48 Or Asc(Mid(Expn, i, 1)) = 46 Then '数字和小数点
            If indexp = 2 Then
               indexp = 1
               ExpArray_bound = ExpArray_bound + 1
            End If
            ReDim Preserve ExpArray(ExpArray_bound)
            ExpArray(ExpArray_bound) = ExpArray(ExpArray_bound) & Mid(Expn, i, 1)
        Else
            ExpArray_bound = ExpArray_bound + 1
            ReDim Preserve ExpArray(ExpArray_bound)
            ExpArray(ExpArray_bound) = Mid(Expn, i, 1)
            indexp = 2
        End If
Next i
End Function

Private Function RemoveSign(Sign1 As String, Sign2 As String)
Dim MarkPoint As Integer
Dim LeftPoint As Integer
Dim LeftVar As String
Dim RightPoint As Integer
Dim RightVar As String
Dim Length_Array As Integer
Dim i As Integer
MarkPoint = 0
LeftPoint = MarkPoint
RightPoint = MarkPoint
Length_Array = UBound(ExpArray)
  For i = 0 To Length_Array
    If ExpArray(i) = Sign1 Or ExpArray(i) = Sign2 Then
       MarkPoint = i
       LeftPoint = MarkPoint - 1
       RightPoint = MarkPoint + 1
            Do While ExpArray(LeftPoint) = "&"
                LeftPoint = LeftPoint - 1
            Loop
            LeftVar = ExpArray(LeftPoint)
            Do While ExpArray(RightPoint) = "&"
                RightPoint = RightPoint + 1
            Loop
            RightVar = ExpArray(RightPoint)
            ExpArray(MarkPoint) = Str(Evaluate(Trim(LeftVar & ExpArray(MarkPoint) & RightVar)))
            ExpArray(LeftPoint) = "&"
            ExpArray(RightPoint) = "&"
    End If
  Next i
End Function

Function AdvanceJS1(x As String)   '主程序入口
Dim CachBound As Integer
Dim cach() As Integer
Dim i As Integer
Dim tmp As String
Dim ExpresionTemp As String
CachBound = 0
    For i = 1 To Len(x)
        If Mid(x, i, 1) = "(" Then
         ReDim Preserve cach(CachBound)
         cach(CachBound) = i
         CachBound = CachBound + 1
        End If
        If Mid(x, i, 1) = ")" Then
        ExpresionTemp = Mid(x, cach(CachBound - 1) + 1, i - cach(CachBound - 1) - 1)
        tmp = Trim(Str(CustomCalculate(ExpresionTemp)))
        x = Left(x, cach(CachBound - 1) - 1) & tmp & Right(x, Len(x) - i)
        i = cach(CachBound - 1)
        CachBound = CachBound - 1
        ReDim Preserve cach(CachBound)
        End If
    Next i
AdvanceJS1 = CustomCalculate(x)
End Function

Rowen

测试OK, 谢谢分享这么好的代码!

另:

单元格为空时进行一下处理更好.

shaoshan

是的,我还准备扩展其功能[em10]

shaoshan

有没有更快更好的方法呢?各位,thinking~~

lfr007

谢谢大神，弄到模板后，能用

lfr007

大神，能帮忙加上去除空格和回车的语句吗？谢谢

熊熊20121229

厉害，牛牛牛牛

有4地

长见识了……………………。

人生如游戏

收藏了，谢谢分享！！

646804566

请问这段代码怎么用呢？