紧急求助高手，如何解决这个水样监测统计，字典法可能最好！

camle

原帖由 灰袍法师 于 2010-12-14 20:53 发表


19选15不多，刚好等于 19选4而已

11628个

一个组合一张表.....

[ 本帖最后由 camle 于 2010-12-14 23:09 编辑 ]

lj1226189

期待高手出手助我

蓝桥玄霜

1. Sub yy1()
   
2. Dim i&, Myr&, Arr, j&
   
3. Dim d, k, t, x
   
4. Set d = CreateObject("Scripting.Dictionary")
   
5. Sheet1.Activate
   
6. Myr = [a65536].End(xlUp).Row
   
7. Arr = Range("a1:t" & Myr)
   
8. ReDim Arr1(1 To Myr - 1)
   
9. For i = 2 To UBound(Arr)
   
10.     x = Arr(i, 2) & "|" & Arr(i, 3) & "|" & Arr(i, 4) & "|" & Arr(i, 6) & "|" & Arr(i, 7) & "|" & Arr(i, 10) & "|" & Arr(i, 11) & "|" & Arr(i, 13) & "|" & Arr(i, 14) & "|" & Arr(i, 15) & "|" & Arr(i, 16) & "|" & Arr(i, 17) & "|" & Arr(i, 18) & "|" & Arr(i, 19) & "|" & Arr(i, 20)
    
11.     d(x) = d(x) & Arr(i, 1) & ","
    
12. Next
    
13. k = d.keys
    
14. t = d.items
    
15. d.RemoveAll
    
16. For i = 0 To UBound(t)
    
17.     t(i) = Left(t(i), Len(t(i)) - 1)
    
18.     If InStr(t(i), ",") Then
    
19.         d(t(i)) = ""
    
20.     End If
    
21. Next
    
22. k = d.keys
    
23. [aa1].Resize(d.Count, 1) = Application.Transpose(k)
    
24. End Sub
    

复制代码

office2008

是组合问题，循环，  取15个相同值，不如取 4 个不同值，4个以上直接否定。

组合问题+ 数组+字典 ， 但是几千个组合 循环 ，那需要什么速度，需要多少时间，我估计 很漫长。

KCFONG

to 20/F
Your VBA is very fast.
But it seems different from mine.
Please investigate.
Thanks very much

northwolves

1. 
   
2. Sub Test()
   
3. Dim arr, t$, i&, j&, k&, m&, n&
   
4. arr = [a1].CurrentRegion
   
5. For k = 2 To UBound(arr)
   
6. t = arr(k, 1) & ":"
   
7. m = 0
   
8. For i = 2 To UBound(arr)
   
9. If i <> k Then
   
10. n = 0
    
11. For j = 2 To 20
    
12. If arr(i, j) <> arr(k, j) Then n = n + 1
    
13. If n > 4 Then Exit For
    
14. Next
    
15. If n < 5 Then t = t & " " & arr(i, 1) & "(" & 19 - n & ")": m = m + 1
    
16. End If
    
17. Next
    
18. If m Then Debug.Print t
    
19. Next
    
20. MsgBox "OK"
    
21. End Sub
    

复制代码

northwolves

23楼代码返回:
1: 2(19)
2: 1(19)
3: 4(19)
4: 3(19)
5: 6(19)
6: 5(19)
7: 8(19)
8: 7(19)
9: 10(19)
10: 9(19)
11: 12(19)
12: 11(19)
13: 14(19)
14: 13(19)
15: 16(19)
16: 15(19)
17: 18(19)
18: 17(19)
492: 493(15)
493: 492(15)
546: 549(15)
549: 546(15)
675: 924(15)
750: 1247(15)
924: 675(15)
1187: 1265(15)
1247: 750(15)
1265: 1187(15)
1378: 1436(15)
1436: 1378(15)
1475: 2249(15)
1978: 4066(16)
1990: 2212(15)
2035: 2036(15)
2036: 2035(15)
2212: 1990(15)
2249: 1475(15)
2267: 2778(15)
2278: 5230(15)
2366: 3538(15)
2446: 3304(15) 3908(15) 6184(17)
2558: 4242(15)
2778: 2267(15)
2819: 3549(16) 3596(15) 6271(15)
3012: 4355(15)
3238: 6154(17)
3304: 2446(15) 3908(16) 4302(15) 6184(16)
3340: 3342(15)
3342: 3340(15)
3408: 3409(16)
3409: 3408(16)
3538: 2366(15)
3549: 2819(16) 3596(15) 6271(15)
3596: 2819(15) 3549(15)
3643: 3977(15)
3718: 6311(15)
3908: 2446(15) 3304(16) 4302(15) 6184(16)
3977: 3643(15)
4066: 1978(16)
4151: 4390(16)
4242: 2558(15)
4302: 3304(15) 3908(15) 6184(15)
4355: 3012(15)
4390: 4151(16)
4747: 5389(15)
5058: 5059(17)
5059: 5058(17)
5230: 2278(15)
5386: 5887(15)
5387: 5888(15)
5389: 4747(15)
5583: 5584(18)
5584: 5583(18)
5631: 7068(15)
5739: 5740(16)
5740: 5739(16)
5812: 5813(15)
5813: 5812(15)
5887: 5386(15)
5888: 5387(15)
5987: 6046(15)
6046: 5987(15)
6079: 6105(15)
6105: 6079(15)
6154: 3238(17)
6159: 6160(15)
6160: 6159(15)
6184: 2446(17) 3304(16) 3908(16) 4302(15)
6202: 6203(16)
6203: 6202(16)
6271: 2819(15) 3549(15)
6310: 7054(15)
6311: 3718(15)
6451: 6452(18)
6452: 6451(18)
6620: 6622(15)
6622: 6620(15)
6822: 6823(15)
6823: 6822(15)
6851: 6852(17)
6852: 6851(17)
6856: 6857(17)
6857: 6856(17)
6872: 6873(16)
6873: 6872(16)
6885: 6886(15)
6886: 6885(15)
7054: 6310(15)
7068: 5631(15)
7221: 7227(15)
7227: 7221(15)
7233: 7234(15)
7234: 7233(15)
7248: 7249(15)
7249: 7248(15)
7254: 7255(15)
7255: 7254(15)
7264: 7265(17)
7265: 7264(17)
7365: 7366(15)
7366: 7365(15)
7378: 7386(15)
7386: 7378(15)
7508: 7532(15)
7532: 7508(15)
7533: 8146(15)
7930: 8554(15)
8018: 8644(15)
8025: 8648(15)
8027: 8653(15)
8031: 8656(15)
8032: 8167(16) 8658(16)
8034: 8661(15)
8035: 8167(16) 8658(15) 8659(15) 8660(15)
8146: 7533(15)
8155: 8791(16)
8157: 8602(15)
8166: 8657(16)
8167: 8032(16) 8035(16) 8659(16) 8660(16) 8661(16)
8259: 8260(18)
8260: 8259(18)
8442: 8454(15)
8454: 8442(15)
8554: 7930(15)
8602: 8157(15)
8644: 8018(15)
8647: 8651(15)
8648: 8025(15)
8651: 8647(15)
8653: 8027(15)
8656: 8031(15)
8657: 8166(16)
8658: 8032(16) 8035(15)
8659: 8035(15) 8167(16) 8660(15)
8660: 8035(15) 8167(16) 8659(15)
8661: 8034(15) 8167(16)
8791: 8155(16)
9013: 9015(16)
9014: 9016(16)
9015: 9013(16)
9016: 9014(16)
9576: 9582(17)
9582: 9576(17)

程序运行170秒,仍有优化余地

KCFONG

Sub Testx()
xx = Timer
Dim arr, t$, i&, j&, k&, m&, n&, z$
arr = [a1].CurrentRegion
For k = 2 To UBound(arr)
    t = arr(k, 1) & ":"
    m = 0
    For i = k + 1 To UBound(arr)
        If i <> k Then
            n = 0
            For j = 2 To 20
                If arr(i, j) <> arr(k, j) Then n = n + 1
                If n > 4 Then GoTo line10:
            Next
            If n < 5 Then
                t = t & " " & arr(i, 1) & "(" & 19 - n & ")": m = m + 1
            End If
line10: End If
   Next i
    If m Then z = z & t & ";"
Next k
[ab:ab].Clear
arr = Split(z, ";")
[ab1].Resize(UBound(arr) + 1, 1) = Application.Transpose(arr)
MsgBox Format(Timer - xx, "mm:ss")
End Sub

江左

娃有思路了，不是排列组合那么麻烦
应该是数组1比对数组2，如果true超过15就pass
不过，还不知道怎样落实

northwolves

1. 
   
2. Sub Test()
   
3. Dim arr, brr, t$, i&, j&, k&, l&, m&, n&, tt!
   
4. arr = [a1].CurrentRegion
   
5. ReDim brr(UBound(arr), 1)
   
6. tt = Timer
   
7. brr(0, 0) = "监测点编号"
   
8. brr(0, 1) = "相似监测点"
   
9. For k = 2 To UBound(arr) - 1
   
10. m = 0
    
11. t = ""
    
12. For i = k + 1 To UBound(arr)
    
13. n = 0
    
14. For j = 2 To 20
    
15. If arr(i, j) <> arr(k, j) Then n = n + 1
    
16. If n > 4 Then Exit For
    
17. Next
    
18. If n < 5 Then t = t & " " & arr(i, 1) & "(" & 19 - n & ")": m = m + 1
    
19. Next
    
20. If m Then
    
21. l = l + 1
    
22. brr(l, 0) = arr(k, 1)
    
23. brr(l, 1) = t
    
24. End If
    
25. Next
    
26. [aa1].Resize(l + 1, 2) = brr
    
27. MsgBox Timer - tt & " seconds"
    
28. End Sub
    

复制代码

监测点编号        相似监测点
1         2(19)
3         4(19)
5         6(19)
7         8(19)
9         10(19)
11         12(19)
13         14(19)
15         16(19)
17         18(19)
492         493(15)
546         549(15)
675         924(15)
750         1247(15)
1187         1265(15)
1378         1436(15)
1475         2249(15)
1978         4066(16)
1990         2212(15)
2035         2036(15)
2267         2778(15)
2278         5230(15)
2366         3538(15)
2446         3304(15) 3908(15) 6184(17)
2558         4242(15)
2819         3549(16) 3596(15) 6271(15)
3012         4355(15)
3238         6154(17)
3304         3908(16) 4302(15) 6184(16)
3340         3342(15)
3408         3409(16)
3549         3596(15) 6271(15)
3643         3977(15)
3718         6311(15)
3908         4302(15) 6184(16)
4151         4390(16)
4302         6184(15)
4747         5389(15)
5058         5059(17)
5386         5887(15)
5387         5888(15)
5583         5584(18)
5631         7068(15)
5739         5740(16)
5812         5813(15)
5987         6046(15)
6079         6105(15)
6159         6160(15)
6202         6203(16)
6310         7054(15)
6451         6452(18)
6620         6622(15)
6822         6823(15)
6851         6852(17)
6856         6857(17)
6872         6873(16)
6885         6886(15)
7221         7227(15)
7233         7234(15)
7248         7249(15)
7254         7255(15)
7264         7265(17)
7365         7366(15)
7378         7386(15)
7508         7532(15)
7533         8146(15)
7930         8554(15)
8018         8644(15)
8025         8648(15)
8027         8653(15)
8031         8656(15)
8032         8167(16) 8658(16)
8034         8661(15)
8035         8167(16) 8658(15) 8659(15) 8660(15)
8155         8791(16)
8157         8602(15)
8166         8657(16)
8167         8659(16) 8660(16) 8661(16)
8259         8260(18)
8442         8454(15)
8647         8651(15)
8659         8660(15)
9013         9015(16)
9014         9016(16)
9576         9582(17)