[已解决]24点易读短小新编程

lichuanboy44

     最近本人在参与vbyou127 的添加数字运算的帖子中得到启发，联想到添加+-*/的数学运算，又联想到24点。
     但现有网上开源的24点VBA编程，主要有递归法和Function等复杂调用，语句大多在100句左右，且过程调用较多，思路较复杂，一般人很难搞懂代码。
     本程序代码较短(60句)，可读性强，运用的均是基本的编程方法，且运行速度较快。
     在此第一次讨论发贴，望各位高手指点，你的指点就是我的进步和收获。

1. Sub 逗24()
   
2. '算法思路：如果给定的点数为a、b、c、d，运算符号为设为X、Y、Z，表达式则为：aXbYcZd
   
3. '如果通过括号来强制规定运算的优先顺序，则共有如下5种运算模式(3!=6种,其中一种重复)
   
4. 'ss1 = "((aXb)Yc)Zd":ss2 = "(aXb)Y(cZd)":ss3 = "(aX(bYc))Zd"
   
5. 'ss4 = "aX((bYc)Zd)":ss5 = "aX(bY(cZd))"
   
6.     On Error Resume Next
   
7.     Application.ScreenUpdating = False
   
8.     Dim sc As Object, dd As Object, pr(1 To 5), ar
   
9.     Dim sjg!               '特注：如果sjg不定义为此单精度型，则3 3 8 8为无解
   
10.     Set sc = CreateObject("ScriptControl")   '核心控件，比Evaluate速度快一倍
    
11.     Set dd = CreateObject("scripting.dictionary")
    
12.     sc.Language = "vbs"           '没懂不用管，反正和上面的ScriptControl配套
    
13.     tb = Timer: p = 1
    
14.     sr = Array("+", "-", "*", "/")     '运算符存入数组
    
15.     arr = [C1:F1]                      '从指定单元格读取数据
    
16.     sjg = 24                           '指定运算结果（可灵活任意指定）
    
17.     ReDim ar(1 To 4, 1 To p)           '存放所有排列
    
18.     '*****************************第一步：计算出指定的四个数据的所有排列
    
19.     '本可和第二步的for循环嵌套，但那样for层数太多，不美观，且速度影响不大
    
20.     For h = 1 To 4
    
21.         For i = 1 To 4
    
22.             If i <> h Then
    
23.                 For j = 1 To 4
    
24.                     If j <> i And j <> h Then
    
25.                         For k = 1 To 4
    
26.                             If k <> j And k <> i And k <> h Then
    
27.                                 ReDim Preserve ar(1 To 4, 1 To p)
    
28.                                 ar(1, p) = arr(1, h): ar(2, p) = arr(1, i)
    
29.                                 ar(3, p) = arr(1, j): ar(4, p) = arr(1, k)
    
30.                                 p = p + 1
    
31.                             End If
    
32.                         Next
    
33.                     End If
    
34.                 Next
    
35.             End If
    
36.         Next
    
37.     Next
    
38.     '*****************************第二步：逐个取出组合数，用五大运算模式全面计算比对
    
39.     For g = 1 To UBound(ar, 2)     '逐个取出组合数
    
40.         a = ar(1, g): b = ar(2, g): c = ar(3, g): d = ar(4, g)
    
41.         With sc   '亦可用易懂的Evaluate替换，但分母为0时运算出错,要注意排错。
    
42.             .ExecuteStatement "a=" & a: .ExecuteStatement "b=" & b  '不懂暂不管
    
43.             .ExecuteStatement "c=" & c: .ExecuteStatement "d=" & d
    
44.             For h = 0 To 3         '3个for依次取出XYZ3个+-*/运算符填入下面的运算模式
    
45.                 For i = 0 To 3
    
46.                     For j = 0 To 3
    
47.                         X = sr(h): Y = sr(i): Z = sr(j)
    
48.                         pr(1) = "((" & a & X & b & ")" & Y & c & ")" & Z & d '模式
    
49.                         pr(2) = "(" & a & X & b & ")" & Y & "(" & c & Z & d & ")"
    
50.                         pr(3) = "(" & a & X & "(" & b & Y & c & "))" & Z & d
    
51.                         pr(4) = a & X & "((" & b & Y & c & ")" & Z & d & ")"
    
52.                         pr(5) = a & X & "(" & b & Y & "(" & c & Z & d & "))"
    
53.                         For k = 1 To 5
    
54.                             ss = pr(k): jg = .eval(ss) = sjg '字符串求值并比对
    
55.                             If jg And Not dd.exists(ss) Then dd(ss) = "" '字典存入
    
56.                         Next
    
57.                     Next
    
58.                 Next
    
59.             Next
    
60.         End With
    
61.     Next
    
62.     '************************************
    
63.     [A1:A8000].Clear
    
64.     [A1].Resize(dd.Count, 1) = WorksheetFunction.Transpose(dd.keys)
    
65.     If [A1] = "" Then [A1] = "无解"
    
66.     [C5] = Format(Timer - tb, "0.000")
    
67.     Application.ScreenUpdating = True
    
68.     'MsgBox Format(Timer - tb, "0.000秒")
    
69. End Sub

复制代码

最佳答案

月排行榜 / 总排行榜

grf1973

2016-5-6 11:07

可以考虑把所有算式去重后再进行判断。这样遇到相同数的情况速度会提高。

1. Sub 逗24aa()
   
2. '算法思路：如果给定的点数为a、b、c、d，运算符号为设为X、Y、Z，表达式则为：aXbYcZd
   
3. '如果通过括号来强制规定运算的优先顺序，则共有如下5种运算模式(3!=6种,其中一种重复)
   
4. 'ss1 = "((aXb)Yc)Zd":ss2 = "(aXb)Y(cZd)":ss3 = "(aX(bYc))Zd"
   
5. 'ss4 = "aX((bYc)Zd)":ss5 = "aX(bY(cZd))"
   
6.     Application.ScreenUpdating = False
   
7.     Dim ar(1 To 4, 1 To 100)
   
8.     Dim sjg!               '特注：如果sjg不定义为此单精度型，则3 3 8 8为无解
   
9.     Set dd = CreateObject("scripting.dictionary")
   
10.     Set d1 = CreateObject("scripting.dictionary")
    
11.     tb = Timer
    
12.     sr = Array("+", "-", "*", "/")     '运算符存入数组
    
13.     arr = [C1:F1]                      '从指定单元格读取数据
    
14.     sjg = 24                           '指定运算结果（可灵活任意指定）
    
15.    
    
16.     '*****************************第一步：计算出指定的四个数据的所有排列
    
17.     '本可和第二步的for循环嵌套，但那样for层数太多，不美观，且速度影响不大
    
18.     For h = 1 To 4: For i = 1 To 4: For j = 1 To 4: For k = 1 To 4
    
19.         If (h - i) * (h - j) * (h - k) * (i - j) * (i - k) * (j - k) <> 0 Then
    
20.             p = p + 1
    
21.             ar(1, p) = arr(1, h): ar(2, p) = arr(1, i)
    
22.             ar(3, p) = arr(1, j): ar(4, p) = arr(1, k)
    
23.         End If
    
24.     Next: Next: Next: Next
    
25.    
    
26.     '*****************************第二步：逐个取出组合数，用五大运算模式全面计算比对
    
27.     'On Error Resume Next
    
28.     For g = 1 To p     '逐个取出组合数
    
29.         a = ar(1, g): b = ar(2, g): c = ar(3, g): d = ar(4, g)
    
30.         For h = 0 To 3: For i = 0 To 3: For j = 0 To 3       '3个for依次取出XYZ3个+-*/运算符填入下面的运算模式
    
31.                     X = sr(h): Y = sr(i): Z = sr(j)
    
32.                     dd("((" & a & X & b & ")" & Y & c & ")" & Z & d) = "" '运算模式,'字典存入不重复值
    
33.                     dd("(" & a & X & b & ")" & Y & "(" & c & Z & d & ")") = ""
    
34.                     dd("(" & a & X & "(" & b & Y & c & "))" & Z & d) = ""
    
35.                     dd(a & X & "((" & b & Y & c & ")" & Z & d & ")") = ""
    
36.                     dd(a & X & "(" & b & Y & "(" & c & Z & d & "))") = ""
    
37.         Next: Next: Next
    
38.     Next
    
39.     For Each pp In dd.keys
    
40.         ss = Application.Evaluate(pp)
    
41.         If CStr(ss) <> "Error 2007" Then
    
42.           If ss = sjg Then d1(pp) = ""
    
43.         End If
    
44.     Next
    
45.     '************************************
    
46.     [A1:A8000].Clear
    
47.     If d1.Count >= 1 Then [A1].Resize(d1.Count, 1) = WorksheetFunction.Transpose(d1.keys) Else [A1] = "无解"
    
48.     [C5] = Format(Timer - tb, "0.000")
    
49.     Application.ScreenUpdating = True
    
50. End Sub

复制代码

跳转到最佳答案楼层

lichuanboy44

在此再献丑，并另附图片

心正意诚身修

我從小就喜歡用四張牌算24.很少遇到對手呢。嘿嘿。

lichuanboy44

      本人运用五大运算模式，得到的结果有许多不规范的括号及类似重复值，本人想优化，想了半天，感觉黔驴技穷，无从下手，再次请高手指点。相关帖子我就不发了，请参见http://www.excelpx.com/thread-417398-1-1.html
     产生不规范括号的原因，是为了通过添加括号强制决定运算优先顺序，编程效率高。
    不规范及类似重复值主要示例如下，并附具数据的附件。
     ((7+8)+4)+5     (7+8)+(4+5)   (7+(8+4))+5  7+((8+4)+5)   7+(8+(4+5))
     ((8+7)+5)+4     (8+7)+(5+4)   (8+(7+5))+4  8+((7+5)+4)  8+(7+(5+4))   
     以上2行为类似重复值，只需随便保留一个即可，且全部括号都不需要。
     8* ((7+5)/4 )     ((7+5)/4)*8   此为类似重复值，保留一个，且去掉不规范的括号
    (10+(2*10))-6    10+((2*10)-6)  等

   
         

grf1973

可以考虑把所有算式去重后再进行判断。这样遇到相同数的情况速度会提高。

1. Sub 逗24aa()
   
2. '算法思路：如果给定的点数为a、b、c、d，运算符号为设为X、Y、Z，表达式则为：aXbYcZd
   
3. '如果通过括号来强制规定运算的优先顺序，则共有如下5种运算模式(3!=6种,其中一种重复)
   
4. 'ss1 = "((aXb)Yc)Zd":ss2 = "(aXb)Y(cZd)":ss3 = "(aX(bYc))Zd"
   
5. 'ss4 = "aX((bYc)Zd)":ss5 = "aX(bY(cZd))"
   
6.     Application.ScreenUpdating = False
   
7.     Dim ar(1 To 4, 1 To 100)
   
8.     Dim sjg!               '特注：如果sjg不定义为此单精度型，则3 3 8 8为无解
   
9.     Set dd = CreateObject("scripting.dictionary")
   
10.     Set d1 = CreateObject("scripting.dictionary")
    
11.     tb = Timer
    
12.     sr = Array("+", "-", "*", "/")     '运算符存入数组
    
13.     arr = [C1:F1]                      '从指定单元格读取数据
    
14.     sjg = 24                           '指定运算结果（可灵活任意指定）
    
15.    
    
16.     '*****************************第一步：计算出指定的四个数据的所有排列
    
17.     '本可和第二步的for循环嵌套，但那样for层数太多，不美观，且速度影响不大
    
18.     For h = 1 To 4: For i = 1 To 4: For j = 1 To 4: For k = 1 To 4
    
19.         If (h - i) * (h - j) * (h - k) * (i - j) * (i - k) * (j - k) <> 0 Then
    
20.             p = p + 1
    
21.             ar(1, p) = arr(1, h): ar(2, p) = arr(1, i)
    
22.             ar(3, p) = arr(1, j): ar(4, p) = arr(1, k)
    
23.         End If
    
24.     Next: Next: Next: Next
    
25.    
    
26.     '*****************************第二步：逐个取出组合数，用五大运算模式全面计算比对
    
27.     'On Error Resume Next
    
28.     For g = 1 To p     '逐个取出组合数
    
29.         a = ar(1, g): b = ar(2, g): c = ar(3, g): d = ar(4, g)
    
30.         For h = 0 To 3: For i = 0 To 3: For j = 0 To 3       '3个for依次取出XYZ3个+-*/运算符填入下面的运算模式
    
31.                     X = sr(h): Y = sr(i): Z = sr(j)
    
32.                     dd("((" & a & X & b & ")" & Y & c & ")" & Z & d) = "" '运算模式,'字典存入不重复值
    
33.                     dd("(" & a & X & b & ")" & Y & "(" & c & Z & d & ")") = ""
    
34.                     dd("(" & a & X & "(" & b & Y & c & "))" & Z & d) = ""
    
35.                     dd(a & X & "((" & b & Y & c & ")" & Z & d & ")") = ""
    
36.                     dd(a & X & "(" & b & Y & "(" & c & Z & d & "))") = ""
    
37.         Next: Next: Next
    
38.     Next
    
39.     For Each pp In dd.keys
    
40.         ss = Application.Evaluate(pp)
    
41.         If CStr(ss) <> "Error 2007" Then
    
42.           If ss = sjg Then d1(pp) = ""
    
43.         End If
    
44.     Next
    
45.     '************************************
    
46.     [A1:A8000].Clear
    
47.     If d1.Count >= 1 Then [A1].Resize(d1.Count, 1) = WorksheetFunction.Transpose(d1.keys) Else [A1] = "无解"
    
48.     [C5] = Format(Timer - tb, "0.000")
    
49.     Application.ScreenUpdating = True
    
50. End Sub

复制代码

grf1973

我有evaluate做的，照理比你的要慢一倍，4数均相同的时候的确如此。但4数相同（6666）就会比你的快一倍。

爱疯

我把链接的贴移过来，这个帖子删掉，在那帖里讨论，OK?

grf1973

没有解决你新帖中不同样式，相同内容的情况。

爱疯

可删吗？

lichuanboy44

grf1973 发表于 2016-5-6 11:08
我有evaluate做的，照理比你的要慢一倍，4数均相同的时候的确如此。但4数相同（6666）就会比你的快一倍。

确实如此，4个6时，我的0.234秒，你的0.078秒。