四组数据中选五个,VBA如何实现

luoyin268

是3^4*4=324

luoyin268

如
1  4  7   10  11
1  4  7   11   10
就是相同，

香川群子

思考了一下，用嵌套递归，或者说是连续调用递归方法解决了。

1. 
   
2. Dim sj, sj2(), jg(), m%, n%, k, l%
   
3. 
   
4. Sub Combin5() '代码主过程
   
5.     tms = Timer
   
6.     sj = [a1].CurrentRegion: m = UBound(sj): n = UBound(sj, 2): Amn = m ^ n * n
   
7.     If Amn > 65536 Then Exit Sub Else ReDim jg(Amn, n + 3): k = 0
   
8.     ReDim sj2(m - 1)
   
9.     For l = 1 To n
   
10.         Call dgZH("", 0, 0) '调用组合递归过程
    
11.     Next
    
12.     [a1].Offset(, n + 2).CurrentRegion = "": [a1].Offset(, n + 2).Resize(Amn, n + 4) = jg
    
13.     MsgBox k & vbCr & Format(Timer - tms, "0.000s")
    
14. End Sub
    
15. 
    
16. Sub dgZH(s$, i%, t%) '组合递归过程
    
17.     Dim j%
    
18.     If t = m - 1 Then
    
19.         p = Split(s, ",")
    
20.         For j = 1 To m - 1
    
21.             sj2(j) = sj(p(j), l)
    
22.         Next
    
23.         Call dgMN("", 0) '在组合递归过程中调用【香川组合】递归过程
    
24.         Exit Sub
    
25.     End If
    
26.     For j = i + 1 To m
    
27.         Call dgZH(s & "," & j, j, t + 1)
    
28.     Next j
    
29. End Sub
    
30. 
    
31. Sub dgMN(s$, t%) '【香川组合】递归过程
    
32.     If t = n - 1 Then
    
33.         For j = 1 To m - 1
    
34.             jg(k, l + j - 1) = sj2(j)
    
35. '            jg(k, n + j + 1) = sj2(j)
    
36.         Next
    
37.         
    
38.         p = Split(s, ",")
    
39.         For j = 1 To n - 1
    
40.             If j < l Then
    
41.                 jg(k, j) = sj(p(j), j)
    
42.             Else
    
43.                 jg(k, j + 2) = sj(p(j), j + 1)
    
44.             End If
    
45.         Next
    
46.         
    
47.         jg(k, 0) = jg(k, 1)
    
48.         For j = 2 To n + 1
    
49.             jg(k, 0) = jg(k, 0) & "," & jg(k, j)
    
50.         Next
    
51.         
    
52.         k = k + 1
    
53.         Exit Sub
    
54.     End If
    
55.     For i = 1 To m
    
56.         Call dgMN(s & "," & i, t + 1)
    
57.     Next
    
58. End Sub
    

复制代码

附件例子中，用了文字数据。
避免数值大小对组合理解的干扰。

luoyin268

谢谢，已经完美解决！！！！！

香川群子

这个问题用VBA数组循环，好像还难以简明解决。

dsmch

香川群子 发表于 2012-11-14 11:00
这个问题用VBA数组循环，好像还难以简明解决。

1. Dim arr, brr(1 To 3 ^ 5 * 4), crr
   
2. Dim a%, b%, c%, d%, e%, f%, x$, s&, s2&, y
   
3. arr = Range("a1").CurrentRegion
   
4. For a = 1 To 3
   
5. For b = 1 To 3
   
6. For c = 1 To 3
   
7. For d = 1 To 3
   
8. x = arr(a, 1) & "," & arr(b, 2) & "," & arr(c, 3) & "," & arr(d, 4)
   
9. For e = 1 To 3
   
10. For f = 1 To 4
    
11.     If InStr("," & x & ",", "," & arr(e, f) & ",") = 0 Then
    
12.         s = s + 1
    
13.        brr(s) = x & "," & arr(e, f)
    
14.     End If
    
15. Next f, e, d, c, b, a
    
16. ReDim crr(1 To s, 1 To 5)
    
17. For i = 1 To s
    
18.     x = "," & brr(i) & ","
    
19.     For j = i + 1 To s
    
20.         y = Split(brr(j), ",")
    
21.         For k = 0 To UBound(y)
    
22.             x = Replace(x, "," & y(k) & ",", ",")
    
23.         Next
    
24.         If x = "," Then brr(j) = ""
    
25.         x = "," & brr(i) & ","
    
26.     Next
    
27. Next
    
28. For i = 1 To s
    
29.     If brr(i) <> "" Then
    
30.         s2 = s2 + 1
    
31.         z = Split(brr(i), ",")
    
32.         For j = 0 To UBound(z)
    
33.             crr(s2, j + 1) = z(j)
    
34.         Next
    
35.     End If
    
36. Next
    
37. Range("f1").Resize(s2, 5) = crr

复制代码

dsmch

附件…………

香川群子

dsmch 发表于 2012-11-14 13:24
附件…………

结果是出来了，但算法不行。
生成全部组合，然后逐个检查比对是否有重复……速度太慢了。

我的递归要比你快 100-200倍。

而且如果原始数据有行数列数增加，你的代码没有通用性无法计算了。


需要考虑好的算法，争取一次性得到不重复结果。
（我的递归已经可以一次性得到结果了，但VBA数组算法还需要挑战。）

香川群子

经研究发现，仅仅对于楼主的特定要求，即【3行4列】，用VBA数组也可以快速解决。

但【超过3行或超过4列】时就无法圆满解决了。（递归代码可以。）

1. Sub kagawa2()
   
2.     tms = Timer
   
3.     arr = Range("a1").CurrentRegion
   
4.     m = UBound(arr): n = UBound(arr, 2)
   
5.     ReDim brr(1 To m ^ n * (m - 1) * n, n + 1): k = 0
   
6.     Dim i1%, i2%, i3%, i4%
   
7.     For i1 = 1 To m
   
8.     For i2 = 1 To m
   
9.     For i3 = 1 To m
   
10.     For i4 = 1 To m
    
11.     For i5 = 1 To m
    
12.     For j5 = 1 To n
    
13.         If j5 = 1 And i5 <= i1 Then GoTo Nxt
    
14.         If j5 = 2 And i5 <= i2 Then GoTo Nxt
    
15.         If j5 = 3 And i5 <= i3 Then GoTo Nxt
    
16.         If j5 = 4 And i5 <= i4 Then GoTo Nxt
    
17.         k = k + 1
    
18.         brr(k, 0) = arr(i1, 1) & "," & arr(i2, 2) & "," & arr(i3, 3) & "," & arr(i4, 4) & "," & arr(i5, j5)
    
19.         brr(k, 1) = arr(i1, 1)
    
20.         brr(k, 2) = arr(i2, 2)
    
21.         brr(k, 3) = arr(i3, 3)
    
22.         brr(k, 4) = arr(i4, 4)
    
23.         brr(k, 5) = arr(i5, j5)
    
24. Nxt:
    
25.     Next j5, i5, i4, i3, i2, i1
    
26.     [a1].Offset(, n + 3).CurrentRegion = ""
    
27.     [a1].Offset(, n + 3).Resize(k, n + 2) = brr
    
28.     MsgBox k & vbCr & Format(Timer - tms, "0.000s")
    
29. End Sub
    

复制代码

luoyin168

但【超过3行或超过4列】时就无法圆满解决了
意思是：如果是３行５列的时候，选出６个为一组，每组至少也选一个！就有点困难了吗？？？？
理论上是３＾５＊５＝１２１５组，用同样的方法，能否实现