R*C数组共计M个选N的组合

micch

先已知一个R行C列的一个二维数组。总数量为M=R*C，从中选N个进行组合。有两个约束条件，选取出来的组合在同一行内不得超过n1个，同一列内不得超过n2个。

以下为举例，比如是8行4列的32个数字，选取6个生成组合。约束条件是：同一行不能超过2个，同一列不能超过3个。


用穷举的方法循环判断代码如下：

1. Sub GetCombin()
   
2.     Dim Source, Result
   
3.     Dim i1&, i2&, i3&, i4&, i5&, i6&
   
4.     Dim j&, k&, M&, N&
   
5.     Const Symbol As String = ";"
   
6.     Source = [=SEQUENCE(,32)]
   
7.     M = 32
   
8.     N = 6
   
9.     k = Application.WorksheetFunction.Combin(M, N)
   
10.     ReDim Result(1 To k, 0)
    
11.    
    
12.     For i1 = 1 To M - 5
    
13.     For i2 = i1 + 1 To M - 4
    
14.     For i3 = i2 + 1 To M - 3
    
15.     For i4 = i3 + 1 To M - 2
    
16.     For i5 = i4 + 1 To M - 1
    
17.     For i6 = i5 + 1 To M - 0
    
18.         If CheckNum(i1, i2, i3, i4, i5, i6) Then
    
19.         j = j + 1
    
20.         Result(j, 0) = Source(i1) & Symbol & Source(i2) & Symbol & Source(i3)
    
21.         Result(j, 0) = Result(j, 0) & Symbol & Source(i4) & Symbol & Source(i5)
    
22.         Result(j, 0) = Result(j, 0) & Symbol & Source(i6)
    
23.         End If
    
24.     Next i6, i5, i4, i3, i2, i1
    
25.     Range("a1").Resize(j).Value = Result
    
26.     MsgBox j & " of " & k
    
27. End Sub
    
28. Private Function CheckNum(ParamArray ar()) As Boolean
    
29.     Dim r(1 To 8), c(1 To 4)
    
30.     For Each i In ar
    
31.         j = Int((i + 3) / 4)
    
32.         k = (i - 1) Mod 4 + 1
    
33.         r(j) = r(j) + 1
    
34.         c(k) = c(k) + 1
    
35.         If r(j) > 2 Then Exit Function
    
36.         If c(k) > 3 Then Exit Function
    
37.     Next
    
38.     CheckNum = True
    
39. End Function

复制代码

（这个代码循环运算量比较大，也不能拓展到任意M和N）优化代码逻辑和速度，怎么处理比较好？？

wanghan519

论坛里应该有vba递归组合的代码，也就应该可以扩展到更多的行列。。。
没有算法上的优化，只是写起来简单点，用的是网页版金山文档，结果数组是出来了，但发现写入行多了会报错，还是不完善啊。。。

micch

PY有库还是方便啊，vba按理说也会有人开发类似的库，估计是太小众哪怕分享了，也没流传开来。

论坛香川老师的递归组合就很好，只不过会用不会改

山菊花

供参考。

jz_l

今铭昔

micch

一维数组递归的勉强理解，可以抄一下；二维行列递归这个感觉更符合人工处理的逻辑，但是理解起来费劲

micch

交作业，递归是真不好用，还是不太会。   一维数组递归组合勉强会抄了，二维行列同时递归，感觉有点深度搜索或者动态规划，思路能想通，代码不会改。先按一维数组递归组合写一个




测试模块

1. 
   
2. ' 有个疑问
   
3. ' 如果不读取单元格32个数字，直接用默认1-32组成数组进行组合，速度 0.5~
   
4. ' 如果读取单元格8行4列的数字，作为数据源数组进行组合，速度 1.1~
   
5. ' 而实际时间的计算是从数据源数组生成后开始计时，也就是组合过程和数据源其实无关
   
6. Sub Test()
   
7.     Dim ar, r As Long
   
8.     With New ClsCombin
   
9. '        .Source = Range("c3:f10").Value     ' 注释后会用默认数组，内容一致
   
10.         ar = .Result
    
11.         If .Cnt < 100 Then r = .Cnt Else r = 100
    
12.     End With
    
13.     Columns(1).ClearContents
    
14.     Range("a1").Resize(r).Value = ar
    
15. End Sub
    
16. 
    
17. 
    
18. 
    
19. Sub Test1()
    
20.     Dim ar, r As Long
    
21.     With New ClsCombin
    
22.         .Source = Range("m3").CurrentRegion.Value
    
23.         .n = Range("k4").Value
    
24.         .nRow = Range("k6").Value
    
25.         .nColumn = Range("k8").Value
    
26.         ar = .Result
    
27.         If .Cnt < 100 Then r = .Cnt Else r = 100
    
28.         Range("H10").Value = .n & " ; " & .nRow & " ; " & .nColumn & " ; " & .Cnt
    
29.         If .Cnt = 0 Then Exit Sub
    
30.     End With
    
31.     Columns(1).ClearContents
    
32.     Range("a1").Resize(r).Value = ar
    
33. End Sub

复制代码

类模块

1. ' 类名称:ClsCombin
   
2. ' 组合递归代码
   
3. ' 读入一个二维数组和抽取数量，行列约束数量，共4个参数，返回符合条件的组合数组
   
4. Option Explicit
   
5. 
   
6. Private m_ As Integer           '-- 元素总数量
   
7. Private n_ As Integer           '-- 抽取数量
   
8. 
   
9. Private nRow_ As Integer        '-- 行约束条件数量
   
10. Private nColumn_ As Integer     '-- 列约束条件数量
    
11. 
    
12. Private Source_                 '-- 数据源转化为一列
    
13. Private Result_                 '-- 结果
    
14. 
    
15. Private ubound1_ As Integer     '-- 数组上限
    
16. Private ubound2_ As Integer     '-- 数组上限
    
17. Private cntMax_ As Long         '-- 组合上限
    
18. Private cnt_ As Long            '-- 组合结果数量
    
19. 
    
20. Private arrNum_() As Integer    '-- 一维数组(备用)
    
21. Private arrRow_() As Integer    '-- 记录行数量
    
22. Private arrColumn_() As Integer '-- 记录列数量
    
23. 
    
24. Public Property Let m(m0 As Integer)
    
25.     m_ = m0
    
26. End Property
    
27. Public Property Get m() As Integer
    
28.     m = m_
    
29. End Property
    
30. Public Property Let n(n0 As Integer)
    
31.     n_ = n0
    
32. End Property
    
33. Public Property Get n() As Integer
    
34.     n = n_
    
35. End Property
    
36. Public Property Let nRow(nRow0 As Integer)
    
37.     nRow_ = nRow0
    
38. End Property
    
39. Public Property Get nRow() As Integer
    
40.     nRow = nRow_
    
41. End Property
    
42. Public Property Let nColumn(nColumn0 As Integer)
    
43.     nColumn_ = nColumn0
    
44. End Property
    
45. Public Property Get nColumn() As Integer
    
46.     nColumn = nColumn_
    
47. End Property
    
48. 
    
49. Public Property Let Source(Source0 As Variant)  '-- 二维数组为数据源
    
50.     ReadSourceArray Source0
    
51. End Property
    
52. Public Property Get Result() As Variant
    
53.     GetCombin
    
54.     Result = Result_
    
55. End Property
    
56. Public Property Get Cnt() As Variant
    
57.     Cnt = cnt_
    
58. End Property
    
59. 
    
60. Public Sub GetCombin()
    
61.     Dim tms
    
62.     tms = Timer
    
63. 
    
64.     cntMax_ = Application.WorksheetFunction.Combin(m_, n_)
    
65.     ReDim Result_(1 To cntMax_, 1 To 1)
    
66.     cnt_ = 0
    
67.     Call Recursion("", 0, 1)
    
68.    
    
69.     MsgBox cnt_ & vbCrLf & Format(Timer - tms, "0.000s")
    
70. End Sub
    
71. Private Sub Recursion(s As String, i As Long, t As Long)
    
72.     Dim j As Long, ss As String
    
73.     For j = i + 1 To m_
    
74.         If arrRow_(Source_(j, 2)) < nRow_ Then
    
75.         If arrColumn_(Source_(j, 3)) < nColumn_ Then
    
76.         If t = n_ Then
    
77.                 cnt_ = cnt_ + 1
    
78.                 Result_(cnt_, 1) = Mid(s & ";" & Source_(j, 1), 2)
    
79.         Else
    
80.                 arrRow_(Source_(j, 2)) = arrRow_(Source_(j, 2)) + 1
    
81.                 arrColumn_(Source_(j, 3)) = arrColumn_(Source_(j, 3)) + 1
    
82.                 Call Recursion(s & ";" & Source_(j, 1), j, t + 1)
    
83.                 arrRow_(Source_(j, 2)) = arrRow_(Source_(j, 2)) - 1
    
84.                 arrColumn_(Source_(j, 3)) = arrColumn_(Source_(j, 3)) - 1
    
85.         End If
    
86.         End If
    
87.         End If
    
88.     Next
    
89. End Sub
    
90. 
    
91. 
    
92. Private Sub Class_Initialize()
    
93.     InitiDefault
    
94. End Sub
    
95. Private Sub Class_Terminate()
    
96. End Sub
    
97. 
    
98. Private Sub InitiDefault()
    
99.     Dim i As Long, j As Long, k As Long
    
100.    
     
101.     n_ = 6
     
102.     nRow_ = 2
     
103.     nColumn_ = 3
     
104.    
     
105.     ubound1_ = 8
     
106.     ubound2_ = 4
     
107.     m_ = ubound1_ * ubound2_
     
108.     ReDim Source_(1 To m_, 1 To 4)
     
109.     For i = 1 To ubound1_
     
110.     For j = 1 To ubound2_
     
111.         k = k + 1
     
112.         Source_(k, 1) = k
     
113.         Source_(k, 2) = i
     
114.         Source_(k, 3) = j
     
115.     Next
     
116.     Next
     
117.     ReDim arrRow_(1 To ubound1_)
     
118.     ReDim arrColumn_(1 To ubound2_)
     
119. End Sub
     
120. Private Sub ReadSourceArray(Source0)
     
121.     Dim i As Long, j As Long, k As Long
     
122.     ubound1_ = UBound(Source0, 1)
     
123.     ubound2_ = UBound(Source0, 2)
     
124.     m_ = ubound1_ * ubound2_
     
125.    
     
126.     ReDim Source_(1 To m_, 1 To 4)
     
127.     For i = 1 To ubound1_
     
128.     For j = 1 To ubound2_
     
129.         k = k + 1
     
130.         Source_(k, 1) = Source0(i, j)
     
131.         Source_(k, 2) = i
     
132.         Source_(k, 3) = j
     
133.     Next
     
134.     Next
     
135.    
     
136.     ReDim arrRow_(1 To ubound1_)
     
137.     ReDim arrColumn_(1 To ubound2_)
     
138.    
     
139. End Sub
     
140. 
     
141. 
     
142. ''''Private Sub Recursion(s As String, i As Long, t As Long)
     
143. ''''    Dim j As Long, ss As String
     
144. ''''    dgn = dgn + 1
     
145. ''''    For j = i + 1 To m_
     
146. ''''        If t = n_ Then
     
147. ''''            '--方案1
     
148. ''''            If CheckNum(s & ";" & Source_(j, 1)) Then
     
149. ''''            cnt_ = cnt_ + 1
     
150. ''''            Result_(cnt_, 1) = Mid(s & ";" & Source_(j, 1), 2)
     
151. ''''            End If
     
152. ''''        Else
     
153. ''''            If CheckNum(s & ";" & Source_(j, 1)) Then
     
154. ''''            Call Recursion(s & ";" & Source_(j, 1), j, t + 1)
     
155. ''''            Else
     
156. ''''            End If
     
157. ''''        End If
     
158. ''''    Next
     
159. ''''End Sub
     
160. ''''Private Function CheckNum(s0 As String) As Boolean
     
161. ''''    Dim ar, br1, br2
     
162. ''''    Dim i As Long, j As Long, r As Long, c As Long
     
163. ''''    ar = Split(s0, ";")
     
164. ''''    ReDim br1(1 To ubound1_)
     
165. ''''    ReDim br2(1 To ubound2_)
     
166. ''''    For i = 1 To UBound(ar)
     
167. ''''        j = ar(i)
     
168. ''''        r = Source_(j, 2)
     
169. ''''        c = Source_(j, 3)
     
170. ''''        br1(r) = 1 + br1(r)
     
171. ''''        br2(c) = 1 + br2(c)
     
172. ''''        If br1(r) > nRow_ Then Exit Function
     
173. ''''        If br2(c) > nColumn_ Then Exit Function
     
174. ''''    Next
     
175. ''''    CheckNum = True
     
176. ''''End Function
     

复制代码

Combin.zip (29.57 KB, 下载次数: 2)

2023-12-30 11:31 上传

点击文件名下载附件

micch

今铭昔 发表于 2023-12-29 23:46

JS代码吧？代码很简洁。

主体部分，就是行和列一起递归，当行抽取数量达到上限时，就结束，没到上限就提取出来组合。列同理。

所以，类似于从  1,1 开始点 到 8,4 结束点，进行路径搜索，搜索的同时记录经过的点，如果同一行或者同一列经过的点超过限制条件，后面的路径就都不走了，退回上一个节点重新向右向下搜索。

总感觉vba也能模拟出来，但是尝试了下，还是没写出来。

今铭昔

micch 发表于 2023-12-30 12:30
JS代码吧？代码很简洁。

主体部分，就是行和列一起递归，当行抽取数量达到上限时，就结束，没到上限 ...