ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

   
高效办公必会的Office实战技巧 永久免费,网表让Excel秒变数据库 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
Excel不给力? 何不试试FoxTable! Excel函数公式学习大典 财务总监教您玩转Excel 免费下载Excel行业应用视频
300集Office 2010微视频教程 Tableau-数据可视化工具 突破Excel限制,用活字格提高效率 13门Excel免费公开课任你学
你的Excel 2010实战技巧学习锦囊 欲罢不能, 过目难忘的 Office 新界面 免费的Excel考勤计算系统
查看: 7320|回复: 13

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

[复制链接]

TA的精华主题

TA的得分主题

发表于 2008-9-5 13:41 | 显示全部楼层 |阅读模式
本帖已被收录到知识树中,索引项:其他结构和算法

我们在工作中有时候要遇到计算某个单元格中表达式的结果,如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

TA的精华主题

TA的得分主题

发表于 2008-9-5 19:38 | 显示全部楼层

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

另:

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

TA的精华主题

TA的得分主题

 楼主| 发表于 2008-9-6 11:16 | 显示全部楼层

TA的精华主题

TA的得分主题

 楼主| 发表于 2008-9-11 23:31 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2014-5-11 13:10 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2014-5-12 16:50 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2014-10-24 11:46 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2016-1-12 09:24 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2016-5-15 10:53 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2016-8-30 19:12 | 显示全部楼层
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

关闭

最新热点上一条 /1 下一条

关注官方微信,高效办公专列,每天发车

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2018-4-24 01:30 , Processed in 0.269896 second(s), 11 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 2001-2017 Wooffice Inc.

   

沪公网安备 31011702000001号 沪ICP备11019229号

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:徐怀玉律师 李志群律师

快速回复 返回顶部 返回列表