ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 效率神器,一键搞定繁琐工作
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
让更多数据处理,一键完成 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
楼主: lj1226189

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

[复制链接]

TA的精华主题

TA的得分主题

发表于 2010-12-14 21:07 | 显示全部楼层
原帖由 灰袍法师 于 2010-12-14 20:53 发表


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

11628个

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

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

TA的精华主题

TA的得分主题

 楼主| 发表于 2010-12-14 21:22 | 显示全部楼层

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

期待高手出手助我

TA的精华主题

TA的得分主题

发表于 2010-12-14 21:58 | 显示全部楼层

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

  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
复制代码

TA的精华主题

TA的得分主题

发表于 2010-12-14 23:11 | 显示全部楼层
是组合问题,循环,  取15个相同值,不如取 4 个不同值,4个以上直接否定。

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

TA的精华主题

TA的得分主题

发表于 2010-12-14 23:19 | 显示全部楼层
to 20/F
Your VBA is very fast.
But it seems different from mine.
Please investigate.
Thanks very much

水样监测v2.rar

349.54 KB, 下载次数: 31

TA的精华主题

TA的得分主题

发表于 2010-12-14 23:50 | 显示全部楼层

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

TA的精华主题

TA的得分主题

发表于 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秒,仍有优化余地

TA的精华主题

TA的得分主题

发表于 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

TA的精华主题

TA的得分主题

发表于 2010-12-15 09:03 | 显示全部楼层
娃有思路了,不是排列组合那么麻烦
应该是数组1比对数组2,如果true超过15就pass
不过,还不知道怎样落实

TA的精华主题

TA的得分主题

发表于 2010-12-15 09:17 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册

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

本版积分规则

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2024-11-15 07:36 , Processed in 0.036852 second(s), 8 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

沪公网安备 31011702000001号 沪ICP备11019229号-2

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:李志群律师

快速回复 返回顶部 返回列表