VBA挑选组合哪一条最多

laoau138

today0427 发表于 2016-10-13 18:24
最痛苦的是，本来列个方程就能解决的问题，他偏不让你列，偏不让你列，眼看着你绕死在题目中不可自拔

小学有方程?  全部还给老师了，
只有一个未知数X，这类方程吧

grf1973

随机撞大运

1. Sub tj()
   
2.     cs = 200
   
3.     ReDim brr(1 To cs)
   
4.     arr = Range("a2:f" & [a65536].End(3).Row)   '源数据
   
5.     arr1 = arr        '源数据
   
6.     n = UBound(arr)
   
7.     Set d = CreateObject("scripting.dictionary")
   
8. 10:
   
9.         p = Int(Rnd * n + 1)        '随机一行
   
10.         x = x & "," & arr1(p, 1)      '记录行入x
    
11.         For j = 2 To UBound(arr1, 2)
    
12.             d(arr1(p, j)) = ""
    
13.         Next
    
14.         s = d.Count       '至此行数字个数
    
15.         If s >= 11 Then       '至此行数字个数>=11的
    
16.             d.RemoveAll      '恢复d
    
17.             n = UBound(arr)      '恢复n
    
18.             arr1 = arr        '恢复源数据
    
19.             If s = 11 Then        '=11的，存入brr
    
20.                 k = k + 1
    
21.                 brr(k) = Mid(x, 2)
    
22.                 If k = cs Then x = "": GoTo 100
    
23.             End If
    
24.             x = ""
    
25.         End If
    
26.         
    
27.         For j = 1 To UBound(arr1, 2)      '第n行代替第p行
    
28.             arr1(p, j) = arr1(n, j)
    
29.         Next
    
30.         n = n - 1
    
31.         GoTo 10
    
32.         
    
33. 100:                     '显示结果
    
34.     For i = 1 To k           '找出次数最多的brr(p)，like '60,11,24,46
    
35.         xrr = Split(brr(i), ",")
    
36.         If nmax < UBound(xrr) Then
    
37.             nmax = UBound(xrr)
    
38.             p = i
    
39.         End If
    
40.     Next
    
41.    
    
42.     d.RemoveAll
    
43.     ReDim crr(1 To nmax + 1, 1 To 6)
    
44.     xrr = Split(brr(p), ",")        '60,11,24,46
    
45.     For i = 0 To UBound(xrr)
    
46.         p = xrr(i)
    
47.         For j = 1 To UBound(arr, 2)
    
48.             crr(i + 1, j) = arr(p, j)
    
49.             If j > 1 Then d(arr(p, j)) = ""
    
50.         Next
    
51.     Next
    
52.     [m21].Resize(100, 100) = ""
    
53.     [m22].Resize(i, 6) = crr
    
54.     [m21].Resize(, d.Count) = d.keys
    
55.     [m21].Resize(, d.Count).Sort Key1:=Range("M21:W21"), Orientation:=xlLeftToRight
    
56. End Sub
    
57.    

复制代码

laoau138

grf1973 发表于 2016-10-13 21:53
随机撞大运

不管这么多，用来玩差不多，

today  快点进来学习

laoau138

grf1973 发表于 2016-10-13 21:53
随机撞大运

VBA截取A列计算五种属性最大连续


http://www.excelpx.com/thread-425037-1-1.html

香川群子

找到最大值了。覆盖6组。

3        12        15        16        17        22        27        29        31        34        35

grf1973

02        04        07        08        10        17        19        23        24        28        29

007        10        17        23        28        29                                       
022        08        10        17        24        29                                       
054        02        04        24        29        33                                       
087        04        10        19        29        34                                       
094        02        10        19        28        29                                       
099        04        07        08        19        24                                       
                                                                               

grf1973

不对不对，再核查。。。。

grf1973

01        03        04        05        15        16        20        23        28        31        33
006        01        03        04        05        31                                       
025        01        05        23        31        33                                       
039        01        16        20        23        28                                       
051        03        04        16        23        28                                       
092        04        15        23        31        33                                       

grf1973

继续撞大运，点个10来次能得出5组的来，6组的撞不到。

1. Sub tj()
   
2.     Dim x$, k%, n&, m%, hs%, s%
   
3.     arr = Range("a2:f" & [a65536].End(3).Row)   '源数据
   
4.     n = UBound(arr): m = UBound(arr, 2)
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     x = ","
   
7. 10:
   
8.         p = Int(Rnd * n + 1)        '随机一行
   
9.         If InStr(x, "," & arr(p, 1) & ",") = 0 Then x = x & arr(p, 1) & "," Else GoTo 10    '记录行入x，如有重复行，重新取随机行
   
10.         For j = 2 To m
    
11.             d(arr(p, j)) = ""
    
12.         Next
    
13.         s = d.Count       '至此行数字个数
    
14.         hs = hs + 1     '涉及的行数
    
15.         If s >= 11 Then       '至此个数>=11的
    
16.             If s = 11 And hs = 4 Then GoTo 100     '=11，涉及4组的，比较所有数组
    
17.             hs = 0
    
18.             x = ","
    
19.             d.RemoveAll      '恢复d
    
20.         End If
    
21.         GoTo 10
    
22.         
    
23. 100:                     '在4组的基础上和源数据所有组比对
    
24.     For i = 1 To UBound(arr)
    
25.         For j = 2 To m
    
26.             If Not d.exists(arr(i, j)) Then Exit For
    
27.         Next
    
28.         If j > m Then
    
29.             k = k + 1
    
30.             For j = 1 To m
    
31.                 arr(k, j) = arr(i, j)
    
32.             Next
    
33.         End If
    
34.     Next
    
35.     [m21].Resize(100, 100) = ""
    
36.     [m21].Resize(, d.Count) = d.keys
    
37.     [m21].Resize(, d.Count).Sort Key1:=Range("M21:W21"), Orientation:=xlLeftToRight
    
38.     [m22].Resize(k, 6) = arr
    
39. End Sub

复制代码

香川群子

grf1973 发表于 2016-10-14 09:17
01        03        04        05        15        16        20        23        28        31        33
006        01        03        04        05        31                                       
025        01        05        23        31        33                                       

满足覆盖5组的11个数组合有很多，而覆盖6组的只有1组。

用随机方法较容易找到覆盖5组的，但很难找到覆盖6租的唯一的一组。