ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
300集Office 2010微视频教程 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
楼主: dongdonggege

[求助] 世界最难的数组怎么赋值

[复制链接]

TA的精华主题

TA的得分主题

发表于 2019-2-18 11:39 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
dongdonggege 发表于 2019-2-17 21:44
老师,我想推荐你看下这个:http://tieba.baidu.com/p/5669949536,用vb做的,可以做移动两根火柴棒的, ...


不可乘除.rar (102.96 KB, 下载次数: 1)
可乘除.rar (114.74 KB, 下载次数: 4)


当你提到*/时,我才想起以前面漏了情况2和情况2:
就是一个数字减一根火柴,变成某数后,多出的这根火柴
情况1,加入到另一个数字里,使其变成某数
情况2,和另一个数组成一个新数,但位数变多。比如5-10=9,可变成15-10=5     
情况3,把减号变成加号。比如2-3=9,可变成2+3=5
对此,这2个版本已加。


但是,可乘除.xlsm还是用Evaluate,因为我想不出怎么写四则运算。

TA的精华主题

TA的得分主题

发表于 2019-2-18 17:33 | 显示全部楼层
本帖最后由 爱疯 于 2019-2-18 17:36 编辑

Option Explicit

Dim Dic1, Dic2, Dic3, result, Sign

'入口
Sub huocai()
    Dim Exp
    Call Init

    Exp = InputBox("移动一根火柴,使其成立", "提问", "5*3=9")
    If Exp = "" Then End
    If IsExp(Exp) = False Then MsgBox "不是算术等式", , "提示": End
    result = Exp & vbLf & "可变成"

    Call Try1(Exp, Dic1)
    Call Try2(Exp, Dic3)
    MsgBox IIf(Len(result) > Len(Exp) + 4, result, "没办法"), , "回答"
End Sub


'创建数据
Private Sub Init()
    Sign = Array("*", "/", "+", "-")

    '可变
    Set Dic1 = CreateObject("scripting.dictionary")
    Dic1("0") = Array(6, 9)
    Dic1("2") = Array(3)
    Dic1("3") = Array(2, 5)
    Dic1("5") = Array(3)
    Dic1("6") = Array(0, 9)
    Dic1("9") = Array(0, 6)
    Dic1("+") = Array("=")
    Dic1("=") = Array("+")

    '可加
    Set Dic2 = CreateObject("scripting.dictionary")
    Dic2("0") = Array(8)
    Dic2("1") = Array(7)
    Dic2("3") = Array(9)
    Dic2("5") = Array(6, 9)
    Dic2("6") = Array(8)
    Dic2("9") = Array(8)
    Dic2("-") = Array("=", "+")
    Dic2("/") = Array("*")

    '可减
    Set Dic3 = CreateObject("scripting.dictionary")
    Dic3("6") = Array(5)
    Dic3("7") = Array(1)
    Dic3("8") = Array(0, 6, 9)
    Dic3("9") = Array(3, 5)
    Dic3("+") = Array("-")
    Dic3("=") = Array("-")
    Dic2("*") = Array("/")

End Sub


'说明:不改变火柴的个数,把自身变成其它数
'尝试1(表达式,字典)
Sub Try1(Exp, d)
    Dim i, j, ch, A, str
    For i = 1 To Len(Exp)
        ch = Mid(Exp, i, 1)
        If d.exists(ch) Then
            A = d(ch)
            For j = LBound(A) To UBound(A)
                str = Exp
                Mid(str, i, 1) = A(j)
                If IsEqual(str) And InStr(result, str) = 0 Then result = result & vbLf & str
            Next j
        End If
    Next i
End Sub


'说明:先从一个数字中取出一根,这根有3种可能
'1)加到其它数上。比如3变成9,0变成8
'2)和任意数字连接。比如4变成14,或者4变成41
'3)改变运算符号。比如-变成+,或者/变成*
'尝试2(表达式,字典)
Sub Try2(Exp, d)
    Dim ch, ch1, ch2, A, Exp1, Exp2
    Dim i, j, k, l
    For i = 1 To Len(Exp)    '遍历所有字符
        ch = Mid(Exp, i, 1)
        If d.exists(ch) Then
            A = d(ch)
            For j = LBound(A) To UBound(A)    '遍历所有字符的替换结果
                Exp1 = Exp
                Mid(Exp1, i, 1) = A(j)
                For k = 1 To Len(Exp1)
                    ch1 = Mid(Exp1, k, 1)
                    Call Try1(Exp1, Dic3)   '1)
                    If VBA.IsNumeric(ch1) Then
                        For l = 1 To 2      '2)
                            ch2 = IIf(l = 1, "1" & ch1, ch1 & "1")
                            Exp2 = Application.Replace(Exp1, k, 1, ch2)
                            If IsEqual(Exp2) And InStr(result, Exp2) = 0 Then result = result & vbLf & Exp2
                        Next l

                    ElseIf ch1 = "-" Then    '3)
                        ch2 = "+"
                        Exp2 = Application.Replace(Exp1, k, 1, ch2)
                        If IsEqual(Exp2) And InStr(result, Exp2) = 0 Then result = result & vbLf & Exp2
                    ElseIf ch1 = "/" Then    '3)
                        ch2 = "*"
                        Exp2 = Application.Replace(Exp1, k, 1, ch2)
                        If IsEqual(Exp2) And InStr(result, Exp2) = 0 Then result = result & vbLf & Exp2
                    End If
                Next k
            Next j
        End If
    Next i
End Sub


'判断两边之和是否相等
Function IsEqual(Exp) As Boolean
'    Dim A, B, i, j
'    If IsExp(Exp) Then
'        A = Split(Replace(Exp, "-", "+-"), "=")
'        For i = 0 To 1
'            B = Split(A(i), "+")
'            A(i) = 0
'            For j = 0 To UBound(B)
'                If B(j) = "" Then B(j) = 0
'                A(i) = A(i) + 0 + B(j)
'            Next j
'        Next i
'        IsEqual = A(0) = A(1)
'        IsEqual = Application.Evaluate(Exp)
'    End If
    Dim A
    If IsExp(Exp) Then
        A = Split(Exp, "=")
        A(0) = GetValue(A(0))
        A(1) = GetValue(A(1))
        IsEqual = A(0) = A(1)
    End If
End Function


'判断表达式
'1. 只能包含数字,加号,减号,等号
'2. 只有1个等号
'3. 不允许++ -- +- -+
Function IsExp(Exp) As Boolean
    Dim i, c, str, A
    Dim tj1, tj2, tj3

    tj1 = True
    str = "0123456789-+*/="
    For i = 1 To Len(Exp)
        c = Mid(Exp, i, 1)
        If InStr(str, c) = 0 Then tj1 = False: Exit For
    Next i

    tj2 = UBound(Split(Exp, "=")) = 1
    tj3 = True
    A = Array("++", "--", "+-", "-+")    '要补充
    For i = 0 To UBound(A)
        If InStr(Exp, A(i)) Then tj3 = False: Exit For
    Next i

    IsExp = tj1 And tj2 And tj3
End Function


'说明:如果不是数字,就按先乘除后加减,依次找出左部分、中部分、右部分,重新合并再判断;直到是数字。
'四则运算(表达式)
Function GetValue(Exp)
    Dim A, Exp1, ch
    Dim i, j, k, l, m, r
    Dim x, numL, numR

    If VBA.IsNumeric(Exp) Then
        GetValue = Exp
    Else
        For i = LBound(Sign) To UBound(Sign)    '遍历运算符
            Exp1 = Exp
            For j = LBound(Sign) To UBound(Sign)
                Exp1 = VBA.Replace(Exp1, Sign(j), "," & Sign(j))
            Next j
            A = VBA.Split(Exp, ",")


            For j = LBound(A) To UBound(A)    '遍历计算项
                x = InStr(Exp, Sign(i))
                If x Then

                    '1)找左数字
                    numL = ""
                    For k = x - 1 To 1 Step -1
                        ch = Mid(Exp, k, 1)
                        If VBA.IsNumeric(ch) = False Or ch = "." Then Exit For
                        numL = ch & numL
                    Next k

                    '2)求左部分
                    If k > 1 Then l = VBA.Left(Exp, k)

                    '3)找右数字
                    numR = ""
                    For k = x + 1 To Len(Exp)
                        ch = Mid(Exp, k, 1)
                        If VBA.IsNumeric(ch) = False Or ch = "." Then Exit For
                        numR = numR & ch
                    Next k

                    '4)求右部分
                    If k < Len(Exp) Then r = Mid(Exp, k)

                    '5)求中部分的值
                    Select Case Sign(i)
                    Case "*"
                        m = numL * 1 * numR
                    Case "/"
                        m = numL / 1 / numR
                    Case "+"
                        m = numL + 0 + numR
                    Case "-"
                        m = numL - 0 - numR
                    End Select

                    '6)重新合并,再判断
                    Exp = l & m & r
                    GetValue = GetValue(Exp)
                End If
            Next j
        Next i
    End If
End Function


49.rar (113.92 KB, 下载次数: 3)





1. try2和try3合并为try2
2. 四则运算,没想出好办法,不知生拆有没有问题,再试吧

TA的精华主题

TA的得分主题

发表于 2019-2-18 18:26 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
49.rar (113.92 KB, 下载次数: 2)

先存着

TA的精华主题

TA的得分主题

 楼主| 发表于 2019-2-18 19:23 | 显示全部楼层
爱疯 发表于 2019-2-18 11:39
当你提到*/时,我才想起以前面漏了情况2和情况2:
就是一个数字减一根火柴,变成某数后,多出 ...

本楼,我测试了可乘除,9组。
1、5+3=12,正确:15-3=12。
2、14+7=1,错误,正确为14-7=7.
3、9+5=9,错误。正确为3+5=8,3+6=9.
4、19-7=9,正确:16-7=9.
5、3+0=5,正确:5+0=5,3+0=3.
6、25+38=65,正确:25+38=63,另一个错误:25+30=55.
7、11+4=1,错误,正确为11-4=7.
8、2*3=9,正确:3*3=9,2*3=6.
9、6/2=5,正确:6/2=3

TA的精华主题

TA的得分主题

发表于 2019-2-19 19:02 | 显示全部楼层
本帖最后由 爱疯 于 2019-2-19 20:26 编辑

Option Explicit

Dim Dic1, Dic2, Dic3, Result

'入口
Sub huocai()
    Dim Exp
    Exp = InputBox("移动一根火柴,使其成立", "提问", "14+7=1")
    '''''''''''''''''''''''''''''''''''''
    '测试method1
    '
    '            Exp = "6+2=2"
    '''''''''''''''''''''''''''''''''''''
    '测试method2
    '
    '            Exp = "8+5=15"
    '            Exp = "8+10=6"
    '            Exp = "8-10=16"
    '''''''''''''''''''''''''''''''''''''
    '测试method3
    '
    '            Exp = "41+6=12"
    '            Exp = "41+2=16"
    '            Exp = "11/2=2"
    '''''''''''''''''''''''''''''''''''''
    If Exp = "" Then End
    If IsExp(Exp) = False Then MsgBox "不是算术等式", , "提示": End
    Result = Exp & vbLf & "可变成"
    Call Init
    Call Method1(Exp, Dic1)
    Call Method2(Exp, Dic3)
    Call Method3(Exp)
    MsgBox IIf(Len(Result) > Len(Exp) + 4, Result, "没办法"), , "回答"
End Sub


'创建数据
Private Sub Init()

'可变
    Set Dic1 = CreateObject("scripting.dictionary")
    Dic1("0") = Array(6, 9)
    Dic1("2") = Array(3)
    Dic1("3") = Array(2, 5)
    Dic1("5") = Array(3)
    Dic1("6") = Array(0, 9)
    Dic1("9") = Array(0, 6)
    Dic1("+") = Array("=")
    Dic1("=") = Array("+")

    '可加
    Set Dic2 = CreateObject("scripting.dictionary")
    Dic2("0") = Array(8)
    Dic2("1") = Array(7)
    Dic2("3") = Array(9)
    Dic2("5") = Array(6, 9)
    Dic2("6") = Array(8)
    Dic2("9") = Array(8)
    Dic2("-") = Array("=", "+")
    Dic2("/") = Array("*")

    '可减
    Set Dic3 = CreateObject("scripting.dictionary")
    Dic3("6") = Array(5)
    Dic3("7") = Array(1)
    Dic3("8") = Array(0, 6, 9)
    Dic3("9") = Array(3, 5)
    Dic3("+") = Array("-")
    Dic3("=") = Array("-")
    Dic2("*") = Array("/")

End Sub


'方法1(表达式,字典)
Sub Method1(Exp, d)
    Dim i, j, ch, A, Exp1
    For i = 1 To Len(Exp)
        ch = Mid(Exp, i, 1)
        If d.exists(ch) Then
            A = d(ch)
            For j = LBound(A) To UBound(A)
                Exp1 = Exp
                Mid(Exp1, i, 1) = A(j)
                If IsEqual(Exp1) And InStr(Result, Exp1) = 0 Then Result = Result & vbLf & Exp1
            Next j
        End If
    Next i
End Sub


'方法2(表达式,字典)
Sub Method2(Exp, d)
    Dim ch, Exp1, A, B, i, j
    For i = 1 To Len(Exp)
        ch = Mid(Exp, i, 1)
        If d.exists(ch) Then    '遍历Exp的可减字符
            A = d(ch)
            For j = LBound(A) To UBound(A)     '遍历Exp的可减字符的替换值
                Exp1 = Exp
                Mid(Exp1, i, 1) = A(j)    '变成减少一根火柴的状态
                Call Method1(Exp1, Dic2)   '1
                Call Exp2Arr(Exp1, B, True)
                Call Join1(B)               '2
                Call sign(B)    '3
            Next j
        End If
    Next i
End Sub

'方法3(表达式)
Sub Method3(Exp)
    Dim A, i, j, Exp1
    Exp1 = Exp
    Call Exp2Arr(Exp, A, True)  '提取数字和运算符
    For i = LBound(A) To UBound(A)    '遍历所有的数
        If VBA.IsNumeric(A(i)) Then
            If Len(A(i)) > 1 Then
                '是不是处理1
                If ((A(i) Like "1*") And (A(i) Like "10*" = False)) Or (A(i) Like "*1") Then
                    If (A(i) Like "1*") And (A(i) Like "10*" = False) Then
                        A(i) = Mid(A(i), 2)  '开头
                    Else
                        A(i) = Left(A(i), Len(A(i)) - 1)    '结尾
                    End If
                    Exp1 = Application.Trim(Replace(Join(A, ","), ",", ""))
                    Call Method1(Exp1, Dic2)   '1
                    Call Join1(A)    '2
                    Call sign(A)    '3
                End If
            End If
        End If
    Next i
End Sub


'连接数字1(表达式的数组)
Sub Join1(ByVal A)
    Dim i, j, ch1, ch2, Exp1, Exp2
    Exp1 = Application.Trim(Replace(Join(A, ","), ",", ""))
    For i = LBound(A) To UBound(A)
        If VBA.IsNumeric(A(i)) Then    '遍历所有的数
            ch1 = A(i)
            For j = 1 To 2
                A(i) = IIf(j = 1, "1" & ch1, ch1 & "1")
                Exp2 = Application.Trim(Replace(Join(A, ","), ",", ""))
                If IsEqual(Exp2) And InStr(Result, Exp2) = 0 Then Result = Result & vbLf & Exp2
            Next j
            A(i) = ch1
        End If
    Next i
End Sub


'改变符号(表达式的数组)
Sub sign(A)
    Dim i, Exp1
    For i = LBound(A) To UBound(A)
        If A(i) = "-" Then  '遍历所有的数
            A(i) = "+"
            Exp1 = Application.Trim(Replace(Join(A, ","), ",", ""))
            If IsEqual(Exp1) And InStr(Result, Exp1) = 0 Then Result = Result & vbLf & Exp1
        ElseIf A(i) = "/" Then
            A(i) = "*"
            Exp1 = Application.Trim(Replace(Join(A, ","), ",", ""))
            If IsEqual(Exp1) And InStr(Result, Exp1) = 0 Then Result = Result & vbLf & Exp1
        End If
    Next i
End Sub


'判断两边之和是否相等
Function IsEqual(Exp) As Boolean
    Dim A
    If IsExp(Exp) Then
        A = Split(Exp, "=")
        A(0) = f(A(0))
        A(1) = f(A(1))
        IsEqual = A(0) = A(1)
    End If
End Function


'判断表达式
Function IsExp(Exp) As Boolean
    Dim i, c, str, A
    Dim tj1, tj2, tj3

    '1. 只能包含数字,加号,减号,等号
    tj1 = True
    str = "0123456789-+*/="
    For i = 1 To Len(Exp)
        c = Mid(Exp, i, 1)
        If InStr(str, c) = 0 Then tj1 = False: Exit For
    Next i

    '2. 只有1个等号
    tj2 = UBound(Split(Exp, "=")) = 1

    '3. 不允许++ -- +- -+
    tj3 = True
    A = Array("++", "--", "+-", "-+")    '要补充
    For i = 0 To UBound(A)
        If InStr(Exp, A(i)) Then tj3 = False: Exit For
    Next i

    IsExp = tj1 And tj2 And tj3
End Function


'无括号四则运算(表达式)
Function f(Exp)
'    f = Application.Evaluate(Exp)
    Dim A, i
    Call Exp2Arr(Exp, A)
    Select Case UBound(A)
    Case 0
        '无运算符
        f = Exp + 0
    Case 2
        '一个运算符
        f = js(A(0), A(2), A(1))
    Case Else
        '多个运算符
        For i = 3 To UBound(A) Step 2
            If yx(A(1)) < yx(A(i)) Then
                A(2) = js(A(i - 1), A(i + 1), A(i))
            Else
                A(0) = js(A(0), A(2), A(1))
                A(1) = A(i)
                A(2) = A(i + 1)
            End If
        Next i
        f = js(A(0), A(2), A(1))
    End Select
End Function


'优先级
Function yx(ch)
    Dim s
    s = "*+/-"
    yx = InStr(s, ch)
    yx = yx Mod 2
End Function


'计算
Function js(x, y, z)
    Select Case z
    Case "+"
        js = x + 0 + y
    Case "-"
        js = x - 0 - y
    Case "*"
        js = x * 1 * y
    Case "/"
        If y <> 0 Then js = x / 1 / y
    End Select
End Function


'表达式转成数组
Sub Exp2Arr(ByVal str, A, Optional x As Boolean = False)
    Dim B, i
    If x Then
        B = Array("+", "-", "*", "/", "=")
    Else
        B = Array("+", "-", "*", "/")
    End If
    For i = LBound(B) To UBound(B)
        str = Replace(str, B(i), "," & B(i) & ",")
    Next i
    A = Split(str, ",")
End Sub







Method1
火柴数不变,自身变为其它数

Method2
先减少一根火柴,再将这根火柴
1 加到其它数字中
2 和数连接
3 改变运算符

Method3
先从某些数中移除数字1,再将这根火柴
1 加到其它数字中
2 和数连接
3 改变运算符






1)我把变化分为3大种,每大种里可能又含几种变化。
   对照上面这个小结,代码就好读些。
   其中,Method3对于某些数中间包含1的没有写,比如4132中的1,4132-2=434可变成432+2=434
   等找到还漏了什么变化方式,再改。

2)庆幸昨天找到并试成功了,虽然不能带括号,但比我自己想的强多了
   规则清晰,比较好学
   迟到一个月的算法——四则混合运算
   https://zhuanlan.zhihu.com/p/30102690


TA的精华主题

TA的得分主题

发表于 2019-2-19 22:05 | 显示全部楼层
本帖最后由 爱疯 于 2019-3-13 09:03 编辑

Option Explicit

Dim Dic1, Dic2, Dic3, Result

'入口
Sub huocai()
    Dim Exp
    '    Exp = InputBox("移动一根火柴,使其成立", "提问", "14+7=1")
    '''''''''''''''''''''''''''''''''''''
    '测试method1
    '
    '            Exp = "6+2=2"
    '''''''''''''''''''''''''''''''''''''
    '测试method2
    '
    '            Exp = "8+5=15"
    '            Exp = "8+10=6"
    '            Exp = "8-10=16"
    '''''''''''''''''''''''''''''''''''''
    '测试method3
    '
    '    Exp = "41+6=12"
    '    Exp = "41+2=16"
    '    Exp = "11/2=2"
    '    Exp = "10132+4=1035"
    '''''''''''''''''''''''''''''''''''''
    If Exp = "" Then End
    If IsExp(Exp) = False Then MsgBox "不是算术等式", , "提示": End
    Result = Exp & vbLf & "可变成"
    Call Init
    Call Method1(Exp, Dic1)
    Call Method2(Exp, Dic3)
    Call Method3(Exp)
    MsgBox IIf(Len(Result) > Len(Exp) + 4, Result, "没办法"), , "回答"
End Sub


'创建数据
Private Sub Init()

'可变
    Set Dic1 = CreateObject("scripting.dictionary")
    Dic1("0") = Array(6, 9)
    Dic1("2") = Array(3)
    Dic1("3") = Array(2, 5)
    Dic1("5") = Array(3)
    Dic1("6") = Array(0, 9)
    Dic1("9") = Array(0, 6)
    Dic1("+") = Array("=")
    Dic1("=") = Array("+")

    '可加
    Set Dic2 = CreateObject("scripting.dictionary")
    Dic2("0") = Array(8)
    Dic2("1") = Array(7)
    Dic2("3") = Array(9)
    Dic2("5") = Array(6, 9)
    Dic2("6") = Array(8)
    Dic2("9") = Array(8)
    Dic2("-") = Array("=", "+")
    Dic2("/") = Array("*")

    '可减
    Set Dic3 = CreateObject("scripting.dictionary")
    Dic3("6") = Array(5)
    Dic3("7") = Array(1)
    Dic3("8") = Array(0, 6, 9)
    Dic3("9") = Array(3, 5)
    Dic3("+") = Array("-")
    Dic3("=") = Array("-")
    Dic2("*") = Array("/")

End Sub


'方法1(表达式,字典)
Sub Method1(Exp, d)
    Dim i, j, ch, A, Exp1
    For i = 1 To Len(Exp)
        ch = Mid(Exp, i, 1)
        If d.exists(ch) Then
            A = d(ch)
            For j = LBound(A) To UBound(A)
                Exp1 = Exp
                Mid(Exp1, i, 1) = A(j)
                If IsEqual(Exp1) And InStr(Result, Exp1) = 0 Then Result = Result & vbLf & Exp1
            Next j
        End If
    Next i
End Sub


'方法2(表达式,字典)
Sub Method2(Exp, d)
    Dim ch, Exp1, A, B, i, j
    For i = 1 To Len(Exp)
        ch = Mid(Exp, i, 1)
        If d.exists(ch) Then    '遍历Exp的可减字符
            A = d(ch)
            For j = LBound(A) To UBound(A)     '遍历Exp的可减字符的替换值
                Exp1 = Exp
                Mid(Exp1, i, 1) = A(j)    '变成减少一根火柴的状态
                Call Method1(Exp1, Dic2)   '1
                Call Exp2Arr(Exp1, B, True)
                Call Join1(B)               '2
                Call sign(B)    '3
            Next j
        End If
    Next i
End Sub

'方法3(表达式)
Sub Method3(Exp)
    Dim A, i, j, Exp1, Num
    Exp1 = Exp
    Call Exp2Arr(Exp, A, True)  '提取数字和运算符
    For i = LBound(A) To UBound(A)    '遍历所有的数
        If VBA.IsNumeric(A(i)) Then
            If A(i) Like "*1*" And A(i) <> 1 Then
                For j = 1 To Len(A(i))    '遍历数中每个1
                    If Mid(A(i), j, 1) = "1" Then
                        Num = A(i)
                        A(i) = Application.Replace(A(i), j, 1, "")
                        If Left(A(i), 1) <> "0" And IsNumeric(A(i)) Then
                            Exp1 = Application.Trim(Replace(Join(A, ","), ",", ""))
                            Call Method1(Exp1, Dic2)   '1
                            Call Join1(A)    '2
                            Call sign(A)    '3
                        End If
                        A(i) = Num
                    End If
                Next j
            End If
        End If
    Next i
End Sub


'连接数字1(表达式的数组)
Sub Join1(ByVal A)
    Dim i, j, ch1, ch2, Exp1, Exp2
    Exp1 = Application.Trim(Replace(Join(A, ","), ",", ""))
    For i = LBound(A) To UBound(A)
        If VBA.IsNumeric(A(i)) Then    '遍历所有的数
            ch1 = A(i)
            For j = 1 To 2
                A(i) = IIf(j = 1, "1" & ch1, ch1 & "1")
                Exp2 = Application.Trim(Replace(Join(A, ","), ",", ""))
                If IsEqual(Exp2) And InStr(Result, Exp2) = 0 Then Result = Result & vbLf & Exp2
            Next j
            A(i) = ch1
        End If
    Next i
End Sub


'改变符号(表达式的数组)
Sub sign(A)
    Dim i, Exp1
    For i = LBound(A) To UBound(A)
        If A(i) = "-" Then  '遍历所有的数
            A(i) = "+"
            Exp1 = Application.Trim(Replace(Join(A, ","), ",", ""))
            If IsEqual(Exp1) And InStr(Result, Exp1) = 0 Then Result = Result & vbLf & Exp1
        ElseIf A(i) = "/" Then
            A(i) = "*"
            Exp1 = Application.Trim(Replace(Join(A, ","), ",", ""))
            If IsEqual(Exp1) And InStr(Result, Exp1) = 0 Then Result = Result & vbLf & Exp1
        End If
    Next i
End Sub


'判断两边之和是否相等
Function IsEqual(Exp) As Boolean
    Dim A
    If IsExp(Exp) Then
        A = Split(Exp, "=")
        A(0) = f(A(0))
        A(1) = f(A(1))
        IsEqual = A(0) = A(1)
    End If
End Function


'判断表达式
Function IsExp(Exp) As Boolean
    Dim i, c, str, A
    Dim tj1, tj2, tj3

    '1. 只能包含数字,加号,减号,等号
    tj1 = True
    str = "0123456789-+*/="
    For i = 1 To Len(Exp)
        c = Mid(Exp, i, 1)
        If InStr(str, c) = 0 Then tj1 = False: Exit For
    Next i

    '2. 只有1个等号
    tj2 = UBound(Split(Exp, "=")) = 1

    '3. 不允许连续符号
    tj3 = True
    Call Exp2Arr(Exp, A)
    For i = LBound(A) + 1 To UBound(A) Step 2
        If VBA.IsNumeric(A(i - 1)) = False Or VBA.IsNumeric(A(i)) Then
            tj3 = False
            Exit For
        End If
    Next i

    IsExp = tj1 And tj2 And tj3
End Function


'无括号四则运算(表达式)
Function f(Exp)
'    f = Application.Evaluate(Exp)
    Dim A, i
    Call Exp2Arr(Exp, A)
    Select Case UBound(A)
    Case 0
        '无运算符
        f = Exp + 0
    Case 2
        '一个运算符
        f = js(A(0), A(2), A(1))
    Case Else
        '多个运算符
        For i = 3 To UBound(A) Step 2
            If yx(A(1)) < yx(A(i)) Then
                A(2) = js(A(i - 1), A(i + 1), A(i))
            Else
                A(0) = js(A(0), A(2), A(1))
                A(1) = A(i)
                A(2) = A(i + 1)
            End If
        Next i
        f = js(A(0), A(2), A(1))
    End Select
End Function


'优先级
Function yx(ch)
    Dim s
    s = "*+/-"
    yx = InStr(s, ch)
    yx = yx Mod 2
End Function


'计算
Function js(x, y, z)
    Select Case z
    Case "+"
        js = x + 0 + y
    Case "-"
        js = x - 0 - y
    Case "*"
        js = x * 1 * y
    Case "/"
        If y <> 0 Then js = x / 1 / y
    End Select
End Function


'表达式转成数组
Sub Exp2Arr(ByVal str, A, Optional x As Boolean = False)
    Dim B, i
    If x Then
        B = Array("+", "-", "*", "/", "=")
    Else
        B = Array("+", "-", "*", "/")
    End If
    For i = LBound(B) To UBound(B)
        str = Replace(str, B(i), "," & B(i) & ",")
    Next i
    A = Split(str, ",")
End Sub










改了上楼的问题,但如果表达式的第1个是负数,还是会报错


-----


因为忘了数字1是2根火柴,所以删了一些代码
huocai_96L.rar (117.51 KB, 下载次数: 3)


TA的精华主题

TA的得分主题

 楼主| 发表于 2019-2-19 22:49 | 显示全部楼层
爱疯 发表于 2019-2-19 22:05
Option Explicit

Dim Dic1, Dic2, Dic3, Result

95楼测试,没出现94楼的情况,明天抽空接着测试。
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

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

GMT+8, 2024-3-29 03:08 , Processed in 0.047284 second(s), 7 queries , Gzip On, Redis On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

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

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

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