|
本帖最后由 爱疯 于 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)
|
|