列出无序组合的数量

liulang0808

一组数据，去重，然后列出所有组合，或者指定数量的组合。
如一组数据：A1,A2,A3,A4,,A5，列出需求的无序组合，其中A1,A2 跟A2,A1算一样的组合。
列出指定数量的组合，一般可以使用多层for循环既能搞定的。

而本次解决办法是字典+递归（如果考虑效率，可以使用数组+递归，大家可以自行酌情调整）


以下是之前发帖，字典凑数。香川老师又给优化意见，大家可以参考。
http://club.excelhome.net/thread-1385584-1-1.html

liulang0808

将A列数据，列出所有组合

1. Dim arr, r, d
   
2. Sub test()
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     Application.ScreenUpdating = False
   
5.     Sheets(1).UsedRange.Offset(1, 1).ClearContents
   
6.     arr = Sheets(1).UsedRange
   
7.     For j = 2 To UBound(arr)
   
8.         If Len(arr(j, 1)) > 0 Then d(arr(j, 1)) = d.Count
   
9.     Next j
   
10.     r = 2
    
11.     arr = d.keys
    
12.     For j = 0 To UBound(arr)
    
13.         d.RemoveAll
    
14.         d(arr(j)) = d.Count
    
15.         dg arr, j + 1
    
16.     Next j
    
17.     Application.ScreenUpdating = True
    
18. End Sub
    
19. 
    
20. Sub dg(arr, j)
    
21.     For i = j To UBound(arr)
    
22.         d(arr(i)) = ""
    
23.         Cells(r, 2) = Join(d.keys, ",")
    
24.         r = r + 1
    
25.         dg arr, i + 1
    
26.         d.Remove (arr(i))
    
27.     Next i
    
28. End Sub

复制代码

下面是修改nm，列出指定数量的组合，nm>=2

1. Dim arr, r, d, nm
   
2. Sub test1()
   
3.     nm = 4
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     Application.ScreenUpdating = False
   
6.     Sheets(1).UsedRange.Offset(1, 1).ClearContents
   
7.     arr = Sheets(1).UsedRange
   
8.     For j = 2 To UBound(arr)
   
9.         If Len(arr(j, 1)) > 0 Then d(arr(j, 1)) = d.Count
   
10.     Next j
    
11.     r = 2
    
12.     arr = d.keys
    
13.     For j = 0 To UBound(arr)
    
14.         d.RemoveAll
    
15.         d(arr(j)) = ""
    
16.         dg arr, j + 1
    
17.     Next j
    
18.     Application.ScreenUpdating = True
    
19. End Sub
    
20. 
    
21. Sub dg(arr, j)
    
22.     For i = j To UBound(arr)
    
23.         d(arr(i)) = ""
    
24.         If d.Count = nm Then
    
25.             Cells(r, 4) = Join(d.keys, ",")
    
26.             r = r + 1
    
27.         Else
    
28.             If d.Count < nm Then
    
29.                 dg arr, i + 1
    
30.             End If
    
31.         End If
    
32.         d.Remove (arr(i))
    
33.     Next i
    
34. End Sub

复制代码

gufengaoyue

1. Dim x, zh
   
2. Sub 所有组合() '所有组合
   
3. Dim arr, t#, brr(), s$, a&, b&
   
4. t = Timer: x = 0:  zh = [b:b]
   
5. Application.ScreenUpdating = False
   
6. Sheets(1).UsedRange.Offset(1, 1).ClearContents
   
7. arr = Sheets(1).UsedRange
   
8. For a = 2 To UBound(arr)
   
9.     If Len(arr(a, 1)) > 0 And InStr(s, "|" & arr(a, 1) & "|") = 0 Then
   
10.         b = b + 1:   ReDim Preserve brr(1 To b):   brr(b) = arr(a, 1)
    
11.         s = s & "|" & arr(a, 1) & "|"
    
12.     End If
    
13. Next
    
14. For a = 1 To b
    
15.     s = brr(a)
    
16.     dg brr, a, s
    
17. Next
    
18. [b2].Resize(x) = zh
    
19. Application.ScreenUpdating = True
    
20. MsgBox Format(Timer - t, "0.00")
    
21. End Sub
    
22. Sub dg(brr, a, s)
    
23.     For b = a + 1 To UBound(brr)
    
24.             ss = s
    
25.             s = s & "," & brr(b)
    
26.             x = x + 1:   zh(x, 1) = s
    
27.             dg brr, b, ss
    
28.     Next
    
29. End Sub
    

复制代码

liulang0808

gufengaoyue 发表于 2018-12-20 12:54

Application.Transpose支撑范围有限的
会超限的

gufengaoyue

liulang0808 发表于 2018-12-20 13:51
Application.Transpose支撑范围有限的
会超限的

改个类型就好了。

blackttea1

谢谢分享。