求助大神棘手难题：数列组合运算，找出数列中运算结果小于误差的所有组合。

micch

水平不够，瞎写一个吧。列出的结果到是不多。因为组合的时候，按每个计算式只组合一次，不会重复出现进行的组合。

比如A+B，x3+x6=22和x1+x4=21.4，误差不到0.9是可以组合的，但是因为21.4和x3+x8=21已经组合过了，所以结果里就没有x3+x6这个计算式了。

1. Sub test()
   
2.     Dim arr, ar, brr(1 To 33333, 1 To 10), d, x%, i%, j%, k%, r&, n&, m%, s
   
3.     w = [b2].Value
   
4.     arr = Range("A5", [b5].End(4))
   
5.     x = UBound(arr)
   
6.     Set d = CreateObject("scripting.dictionary")
   
7.    
   
8.         For i = 1 To 9 Step 2
   
9.                             Set d(i) = CreateObject("scripting.dictionary")
   
10.         Next
    
11.         For i = 1 To x
    
12.             For k = i To x '组合1
    
13.                             d(1)(arr(i, 1) + "+" + arr(k, 1)) = arr(i, 2) + arr(k, 2)
    
14.                 For j = k To x '组合4
    
15.                             d(7)(arr(i, 1) + "+" + arr(k, 1) + "+" + arr(j, 1)) = arr(i, 2) + arr(k, 2) + arr(j, 2)
    
16.         Next j, k, i
    
17.         For Each s In d(1).keys '组合2
    
18.             For i = 1 To x
    
19.                 If InStr(s, arr(i, 1)) = 0 Then
    
20.                             If d(1)(s) - arr(i, 2) >= 0 Then d(3)(s + "-" + arr(i, 1)) = d(1)(s) - arr(i, 2)
    
21.                     For k = i To x '组合3
    
22.                         If InStr(s, arr(k, 1)) = 0 Then
    
23.                             If d(1)(s) - arr(i, 2) - arr(k, 2) >= 0 Then d(5)(s + "-" + arr(i, 1) + "-" + arr(k, 1)) = d(1)(s) - arr(i, 2) - arr(k, 2)
    
24.                         End If
    
25.                     Next
    
26.                 End If
    
27.         Next i, s
    
28.         For Each s In d(7).keys '组合5
    
29.             For i = 1 To x
    
30.                 If InStr(s, arr(i, 1)) = 0 Then
    
31.                     For k = i To x
    
32.                         If InStr(s, arr(k, 1)) = 0 Then
    
33.                             If d(7)(s) - arr(i, 2) - arr(k, 2) >= 0 Then d(9)(s + "-" + arr(i, 1) + "-" + arr(k, 1)) = d(7)(s) - arr(i, 2) - arr(k, 2)
    
34.                         End If
    
35.                     Next
    
36.                 End If
    
37.         Next i, s
    
38.    
    
39.         For i = 1 To 9 Step 2
    
40.                     ar = Application.Transpose(Array(d(i).keys, d(i).items))
    
41.                     r = 0
    
42.                     Call px(ar, brr, r, 0, w, i)
    
43.         Next
    
44.     [c5:l9999].ClearContents
    
45.     [c5].Resize(r, 10) = brr
    
46. End Sub
    
47. Sub px(ar, brr, r, n, w, m)
    
48.     For i = 1 To UBound(ar)
    
49.     For k = i + 1 To UBound(ar)
    
50.                     If ar(i, 2) > ar(k, 2) Then
    
51.                         t = ar(i, 1): ar(i, 1) = ar(k, 1): ar(k, 1) = t
    
52.                         y = ar(i, 2): ar(i, 2) = ar(k, 2): ar(k, 2) = y
    
53.                     End If
    
54.     Next k, i
    
55.     For i = 1 To UBound(ar) - 1
    
56.             If ar(i + 1, 2) - ar(i, 2) <= w Then
    
57.                         a = ar(i, 2): r = r + 1: n = n + 1
    
58.                         brr(r, m) = "第 " & n & " 组"
    
59.                         r = r + 1
    
60.                         brr(r, m) = ar(i, 1): brr(r, 1 + m) = ar(i, 2)
    
61.                         r = r + 1
    
62.                         brr(r, m) = ar(i + 1, 1): brr(r, m + 1) = ar(i + 1, 2)
    
63.                         Do
    
64.                                 i = i + 1
    
65.                                 If ar(i + 1, 2) - a <= w Then
    
66.                                             r = r + 1
    
67.                                             brr(r, m) = ar(i + 1, 1): brr(r, m + 1) = ar(i + 1, 2)
    
68.                                 Else
    
69.                                             Exit Do
    
70.                                 End If
    
71.                         Loop
    
72.             End If
    
73.     Next
    
74. End Sub
    

复制代码

lumou

micch 发表于 2020-3-9 14:08
水平不够，瞎写一个吧。列出的结果到是不多。因为组合的时候，按每个计算式只组合一次，不会重复出现进行的 ...

能在VBA版等到您的回复，非常感谢！
代码非常棒！

lumou

micch 发表于 2020-3-9 14:08
水平不够，瞎写一个吧。列出的结果到是不多。因为组合的时候，按每个计算式只组合一次，不会重复出现进行的 ...

micch老师，非常感谢您的代码，非常管用
这段时间运行了一些数据，当每组少于15个时电脑还比较容易运行，数据多了就老死机。
所以准备把这个五个组合拆成5组代码，分别运行。拆了很多回，每次总出现错误引用，控变量等问题。请问如何拆分合适？
多次麻烦您，再次感谢！

lumou

有没有哪位好心的大神能帮忙拆分一下啊，
小白一个，万分感谢

yjh_27

lumou 发表于 2020-3-17 11:01
有没有哪位好心的大神能帮忙拆分一下啊，
小白一个，万分感谢

我32L 附件不需拆分。只是组合5的
改组合3，只要把c  循环删除，相关逻辑判断删除即可。

其他同理。
不会连删除都不会吧

lumou

yjh_27 发表于 2020-3-17 13:30
我32L 附件不需拆分。只是组合5的
改组合3，只要把c  循环删除，相关逻辑判断删除即可。

非常感谢，VBA小白一个，同实验室的人都不太会，所以只好上来请教。
另外，运行了一下，发现最多只能运算9个数，多了就不运算了。而我的数据中，有的一组有20多个数据。
这个该怎么修改一下？麻烦了！

yjh_27

lumou 发表于 2020-3-17 18:26
非常感谢，VBA小白一个，同实验室的人都不太会，所以只好上来请教。
另外，运行了一下，发现最多只能运 ...

arr = [a5:b13]
改这里

lumou

yjh_27 发表于 2020-3-17 23:15
arr = [a5:b13]
改这里

明白了。
我手上有好几十组数据，后期可能还有更多。但每组数据数量不太相同，我改了一下，发下每组数据如果不同，那么每次都要改这个参数。
该哪个参数，能一次性解决这个问题码？
再次感谢！

yjh_27

lumou 发表于 2020-3-18 15:02
明白了。
我手上有好几十组数据，后期可能还有更多。但每组数据数量不太相同，我改了一下，发下每组数据 ...

套用41L

arr = Range("A5", [b5].End(4))

lumou

yjh_27 发表于 2020-3-18 15:09
套用41L

arr = Range("A5", .End(4))

可以聊，再次感谢您耐心的答复！