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

camle · 发表于 2010-12-14 21:07

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

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

11628个

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

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

lj1226189 · 发表于 2010-12-14 21:22

期待高手出手助我

蓝桥玄霜 · 发表于 2010-12-14 21:58

Sub yy1()
Dim i&, Myr&, Arr, j&
Dim d, k, t, x
Set d = CreateObject("Scripting.Dictionary")
Sheet1.Activate
Myr = [a65536].End(xlUp).Row
Arr = Range("a1:t" & Myr)
ReDim Arr1(1 To Myr - 1)
For i = 2 To UBound(Arr)
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)
d(x) = d(x) & Arr(i, 1) & ","
Next
k = d.keys
t = d.items
d.RemoveAll
For i = 0 To UBound(t)
t(i) = Left(t(i), Len(t(i)) - 1)
If InStr(t(i), ",") Then
d(t(i)) = ""
End If
Next
k = d.keys
[aa1].Resize(d.Count, 1) = Application.Transpose(k)
End Sub

复制代码

office2008 · 发表于 2010-12-14 23:11

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

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

KCFONG · 发表于 2010-12-14 23:19

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

northwolves · 发表于 2010-12-14 23:50

Sub Test()
Dim arr, t$, i&, j&, k&, m&, n&
arr = [a1].CurrentRegion
For k = 2 To UBound(arr)
t = arr(k, 1) & ":"
m = 0
For i = 2 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 Exit For
Next
If n < 5 Then t = t & " " & arr(i, 1) & "(" & 19 - n & ")": m = m + 1
End If
Next
If m Then Debug.Print t
Next
MsgBox "OK"
End Sub

复制代码

northwolves · 发表于 2010-12-15 00:03

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 · 发表于 2010-12-15 04:24

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

江左 · 发表于 2010-12-15 09:03

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

northwolves · 发表于 2010-12-15 09:17

Sub Test()
Dim arr, brr, t$, i&, j&, k&, l&, m&, n&, tt!
arr = [a1].CurrentRegion
ReDim brr(UBound(arr), 1)
tt = Timer
brr(0, 0) = "监测点编号"
brr(0, 1) = "相似监测点"
For k = 2 To UBound(arr) - 1
m = 0
t = ""
For i = k + 1 To UBound(arr)
n = 0
For j = 2 To 20
If arr(i, j) <> arr(k, j) Then n = n + 1
If n > 4 Then Exit For
Next
If n < 5 Then t = t & " " & arr(i, 1) & "(" & 19 - n & ")": m = m + 1
Next
If m Then
l = l + 1
brr(l, 0) = arr(k, 1)
brr(l, 1) = t
End If
Next
[aa1].Resize(l + 1, 2) = brr
MsgBox Timer - tt & " seconds"
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)

		自动登录	找回密码
密码			免费注册

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

vba可以只有狼版能做出来，SQL我不厉害！

如果要全部求得，要进行x中的组合

向狼版主致敬,班门弄斧一下