查找组合数

hnandi

如图，想查找出现最多次的数据组合，2、3、4、5个数的组合

yynrzwh

2个数的组合 查找组合.rar (26.87 KB, 下载次数: 9)

2024-2-26 17:48 上传

点击文件名下载附件

hnandi

yynrzwh 发表于 2024-2-26 17:49
2个数的组合

谢谢你的回复，如果我要三个数组合、四个数组合和五个数组合又要怎么做呢？

gwjkkkkk

Option Explicit
Sub TEST7()
    Dim ar, br, cr, dr(), er(), vResult(), isFlag As Boolean
    Dim i&, j&, k&, r&, n&, iMax&, vKey, dic As Object, t#
   
    Application.ScreenUpdating = False
    Set dic = CreateObject("Scripting.Dictionary")
    t = Timer
   
    With [A1].CurrentRegion
        ar = .Value
        br = Intersect(.Offset(), .Offset(, 1))
        .Interior.Color = xlNone
        For i = 2 To UBound(ar)
            dr = Application.Index(br, i)
            ReDim er(1 To [L1].Value)
            ReDim vResult(1 To WorksheetFunction.Combin(UBound(dr), [L1].Value))
            combinArr dr, er, vResult, [L1].Value
            For j = 1 To UBound(vResult)
                dic(Join(vResult(j))) = dic(Join(vResult(j))) + 1
            Next j
        Next i
        iMax = Application.Max(dic.Items)
        ReDim br(1 To dic.Count, 1 To [L1].Value)
        For Each vKey In dic.Keys
            If dic(vKey) = iMax Then
                cr = Split(vKey)
                r = r + 1
                For j = 0 To UBound(cr)
                    br(r, j + 1) = cr(j)
                Next j
            End If
        Next
        
        [L2].CurrentRegion.Offset(1).Clear
        [L2].Resize(r, UBound(br, 2)) = br
        [N1].Value = iMax
        
        n = 2
        For i = 1 To r
            n = n + 1
            If n = 56 Then n = 3
            For k = 2 To UBound(ar)
                dic.RemoveAll
                For j = 2 To UBound(ar, 2)
                    dic(CStr(ar(k, j))) = j
                Next j
                isFlag = True
                For j = 1 To UBound(br, 2)
                    If Not dic.Exists(br(i, j)) Then isFlag = False
                Next j
                If isFlag Then
                    For j = 1 To UBound(br, 2)
                        .Cells(k, dic(br(i, j))).Interior.ColorIndex = n
                    Next j
                End If
            Next k
        Next i
    End With
   
    Set dic = Nothing
    Application.ScreenUpdating = True
    MsgBox "执行完毕!_用时:  " & Format(Timer - t, "0.00") & "  秒", 64
End Sub

Function combinArr(ByRef ar(), ByRef br(), ByRef cr(), ByVal n&, Optional ByRef iGroup&, Optional ByVal iStart&, Optional ByVal iNum& = 1)
    Dim i&, j&
    For i = iStart + 1 To UBound(ar) - n + iNum
        If iNum < n Then
           br(iNum) = ar(i)
           Call combinArr(ar, br, cr, n, iGroup, i, iNum + 1)
        Else
           br(iNum) = ar(i)
           iGroup = iGroup + 1
           cr(iGroup) = br
        End If
    Next
End Function

gwjkkkkk

请参考。。。

yjh_27

2个，5次。34、35。

titi012

参与一下啊。
使用递归法，适应不同个数的组合，1-7个。填充颜色就随便填一下了

1. Option Explicit
   
2. Dim Arr, Trr(), Brr, d As Object
   
3. Dim i&, j&, x&, y&
   
4. Dim xStr As String
   
5. Dim MaxN&, aN&, bN&, H&, k
   
6. 
   
7. Sub ZuHe()
   
8. 
   
9. With Range("a2:g" & Cells(Rows.Count, 1).End(xlUp).Row)
   
10.     .Interior.Pattern = xlNone
    
11.     Arr = .Value
    
12. End With
    
13. aN = 7: bN = [L1]
    
14. ReDim Trr(1 To UBound(Arr), 1 To JCnum(aN) / (JCnum(bN) * JCnum(aN - bN)))
    
15. Set d = CreateObject("scripting.dictionary")
    
16. 
    
17. For x = 1 To UBound(Arr)
    
18.     y = 0
    
19.     DiGui aN, bN, ""
    
20. Next x
    
21. 
    
22. MaxN = WorksheetFunction.Large(d.Items, 1)
    
23. [n1] = MaxN: H = 1
    
24. Range("L2:Q9999").ClearContents
    
25. For Each k In d.keys
    
26.     If d(k) = MaxN Then
    
27.         H = H + 1
    
28.         Brr = Split(k, " ")
    
29.         Range("L" & H).Resize(1, UBound(Brr) + 1) = Brr
    
30.         
    
31.         For x = 1 To UBound(Trr)
    
32.         For y = 1 To UBound(Trr, 2)
    
33.             If Trr(x, y) Like k Then
    
34.                 For i = 0 To UBound(Brr)
    
35.                 For j = 1 To UBound(Arr, 2)
    
36.                     If Arr(x, j) Like Brr(i) Then Cells(x + 1, j).Interior.Color = RGB(0, 255, 255)
    
37.                 Next j, i
    
38.                 Exit For
    
39.             End If
    
40.         Next y, x
    
41.         
    
42.     End If
    
43. Next k
    
44. 
    
45. End Sub
    
46. 
    
47. Sub DiGui(ByVal N As Long, R As Long, T As String)
    
48.    
    
49.     If R = 1 Then
    
50.         For i = 1 To N
    
51.             y = y + 1
    
52.             Trr(x, y) = Arr(x, i) & " " & T
    
53.             d(Trr(x, y)) = d(Trr(x, y)) + 1
    
54.         Next i
    
55.         Exit Sub
    
56.     ElseIf N = R Then
    
57.         y = y + 1
    
58.         For i = 1 To N
    
59.             Trr(x, y) = Trr(x, y) & Arr(x, i) & " "
    
60.         Next i
    
61.         Trr(x, y) = Trr(x, y) & T
    
62.         d(Trr(x, y)) = d(Trr(x, y)) + 1
    
63.         Exit Sub
    
64.     End If
    
65.     DiGui N - 1, R, T
    
66.     DiGui N - 1, R - 1, Arr(x, N) & " " & T
    
67.    
    
68. End Sub
    
69. 
    
70. Function JCnum(xNum As Long) As Long
    
71.    
    
72.     JCnum = xNum
    
73.     If xNum = 1 Then JCnum = 1: Exit Function
    
74.     JCnum = JCnum * JCnum(xNum - 1)
    
75. 
    
76. End Function

复制代码