凑数之简化版【随机凑数】

zpy2

香川群子 发表于 2017-11-1 09:34
目前是完全随机调整，计算效率是非常低的（很多次随机结果是无效的），只适合于少量数据的凑数。

可以 ...

嗯，理论上分支定界法比较好，也可以用字典存入部分组合，但是，这样一个是代码比较繁琐，其次，规定一定精度建模的话，用规划求解lingo肯定会快些。
算24点，纯随机也差不多秒杀了。

zpy2

一把小刀闯天下 发表于 2017-11-1 09:56
'来个VBA的

Option Explicit

不错，用递归加遍历，程序简洁明了，4或5个数应该也是秒杀，不知道多层会不会溢出？

天堑小舟

超级强大。                     

香川群子

zpy2 发表于 2017-11-1 10:56
不错，用递归加遍历，程序简洁明了，4或5个数应该也是秒杀，不知道多层会不会溢出？

我很早就写过递归算24的代码了，而且我是计算全部组合。不是只出一组解。

1. Public drr(1 To 3888, 1 To 2), m, cnt, b
   
2. Sub test2() 'by kagawa 2012/1/27
   
3.     tms = Timer
   
4.     Erase drr
   
5.     n = [a1].End(4).Row
   
6.     ReDim arr(1 To n, 1 To 2)
   
7.     For i = 1 To n
   
8.         arr(i, 1) = Cells(i, 1)
   
9.         arr(i, 2) = Cells(i, 1)
   
10.     Next
    
11.     b = [d1]
    
12.    
    
13.     m = 0: cnt = 0
    
14.     zhjs arr, n
    
15.    
    
16.     [e1] = m
    
17.     [d3].CurrentRegion.Offset(1) = ""
    
18.     If m Then [d3].Resize(m, 2) = drr
    
19.    
    
20.     MsgBox Format(Timer - tms, "0.000s ") & m & "/" & cnt
    
21. End Sub
    
22. Sub zhjs(arr(), n)
    
23.     ReDim brr(1 To n - 1, 1 To 2)
    
24.     For i = 1 To n - 1
    
25.         For j = i + 1 To n
    
26.             If n > 2 Then
    
27.                 l = 0
    
28.                 For k = 1 To n
    
29.                     If k <> i And k <> j Then
    
30.                         l = l + 1
    
31.                         brr(l, 1) = arr(k, 1)
    
32.                         brr(l, 2) = arr(k, 2)
    
33.                     End If
    
34.                 Next
    
35.             End If
    
36.             
    
37.             For f = 1 To 6
    
38.             
    
39.                 If f = 6 And arr(i, 1) = 0 Then
    
40. '                    [f1] = [f1] + 1
    
41.                 ElseIf f = 5 And arr(j, 1) = 0 Then
    
42. '                    [f1] = [f1] + 1
    
43.                 Else
    
44.                     brr(n - 1, 1) = js(arr(i, 1), arr(j, 1), f)
    
45.                     brr(n - 1, 2) = jg(arr(i, 2), arr(j, 2), f)
    
46.                     If n = 2 Then
    
47.                         cnt = cnt + 1
    
48.                         If Round(brr(n - 1, 1), 12) = b Then
    
49.                             m = m + 1
    
50.                             drr(m, 1) = brr(n - 1, 1)
    
51.                             drr(m, 2) = brr(n - 1, 2)
    
52.                         End If
    
53.                     Else
    
54.                         zhjs brr, n - 1
    
55.                     End If
    
56.                 End If
    
57.             Next
    
58.         Next
    
59.     Next
    
60. End Sub
    
61. 
    
62. Function js(n1, n2, f)
    
63.     Select Case f
    
64.         Case 1
    
65.             js = n1 + n2
    
66.         Case 2
    
67.             js = n1 - n2
    
68.         Case 3
    
69.             js = n2 - n1
    
70.         Case 4
    
71.             js = n1 * n2
    
72.         Case 5
    
73.             If n2 = 0 Then js = "!0" Else js = n1 / n2
    
74.         Case 6
    
75.             If n1 = 0 Then js = "!0" Else js = n2 / n1
    
76.     End Select
    
77. End Function
    
78. 
    
79. Function jg(n1, n2, f)
    
80.     Select Case f
    
81.         Case 1
    
82.             jg = "(" & n1 & "+" & n2 & ")"
    
83.         Case 2
    
84.             jg = "(" & n1 & "-" & n2 & ")"
    
85.         Case 3
    
86.             jg = "(" & n2 & "-" & n1 & ")"
    
87.         Case 4
    
88.             jg = "(" & n1 & "*" & n2 & ")"
    
89.         Case 5
    
90.             If n2 = 0 Then jg = "/Zero" Else jg = "(" & n1 & "/" & n2 & ")"
    
91.         Case 6
    
92.             If n1 = 0 Then jg = "/Zero" Else jg = "(" & n2 & "/" & n1 & ")"
    
93.     End Select
    
94. End Function

复制代码

学不完用不尽

留下脚印一串串。

coverne

先做个记号，遇到时再来学习

tangqun666

好，贴，学习研究.......

18617515856

香川老师，刚看了你的凑数帖子，您的算法太强大了，我在工作中遇到一点问题，需要用到凑数，但是数据量很大，需要在近万条数据中凑几十个数而且有小数，并将结果显示出来，您能帮帮我吗？

18617515856

香川老师，我找到了您的一个作品可以用在我遇到的问题上，正在研究，真是太强大了，膜拜大神啊

香川群子

抽空，把随机凑数的连续分组凑数功能完善了一下。

键入新的分组序号以后运行宏，可以在保留已经分组结果的基础上，对未分组的部分进行新的分组。
如果留空则仅对数据按原始序号排序。