Excel精英培训网

 找回密码
 注册
数据透视表40+个常用小技巧,让你一次学会!
查看: 2796|回复: 4

[已解决]挑选六个号码组合

[复制链接]
发表于 2015-2-15 21:49 | 显示全部楼层 |阅读模式
本帖最后由 mmc998 于 2015-2-16 20:02 编辑

工作簿选六个.rar (7.52 KB, 下载次数: 41)
excel精英培训的微信平台,每天都会发送excel学习教程和资料。扫一扫明天就可以收到新教程
发表于 2015-2-16 10:26 | 显示全部楼层    本楼为最佳答案   
  1. Sub Macro1()
  2. On Error Resume Next
  3. Dim w, dic, a%, b%, c%, d%, e%, f%, s&
  4. Set dic = CreateObject("scripting.dictionary")
  5. w = [a1:ae1]
  6. n = UBound(w, 2)
  7. For a = 1 To n - 5
  8.     For b = a + 1 To n - 4
  9.         For c = b + 1 To n - 3
  10.             For d = c + 1 To n - 2
  11.                 For e = d + 1 To n - 1
  12.                     For f = e + 1 To n
  13.                         For i = 1 To 3
  14.                             a1 = Mid(w(1, a), i, 1)
  15.                             b1 = Mid(w(1, b), i, 1)
  16.                             c1 = Mid(w(1, c), i, 1)
  17.                             d1 = Mid(w(1, d), i, 1)
  18.                             e1 = Mid(w(1, e), i, 1)
  19.                             f1 = Mid(w(1, f), i, 1)
  20.                             dic(a1) = dic(a1) + 1
  21.                             dic(b1) = dic(b1) + 1
  22.                             dic(c1) = dic(c1) + 1
  23.                             dic(d1) = dic(d1) + 1
  24.                             dic(e1) = dic(e1) + 1
  25.                             dic(f1) = dic(f1) + 1
  26.                         Next
  27.                         If Join(dic.items, "") = String(9, "2") Then
  28.                             s = s + 1
  29.                             Cells(s + 2, 1) = w(1, a)
  30.                             Cells(s + 2, 2) = w(1, b)
  31.                             Cells(s + 2, 3) = w(1, c)
  32.                             Cells(s + 2, 4) = w(1, d)
  33.                             Cells(s + 2, 5) = w(1, e)
  34.                             Cells(s + 2, 6) = w(1, f)
  35.                         End If
  36.                         dic.RemoveAll
  37.                     Next
  38.                 Next
  39.             Next
  40.         Next
  41.     Next
  42. Next
  43. End Sub
复制代码

评分

参与人数 1 +3 收起 理由
新一 + 3 赞一个!

查看全部评分

回复

使用道具 举报

发表于 2015-2-17 09:29 | 显示全部楼层
2楼字典法速度太慢……看我的附件,速度快20倍。
  1. Dim sj(), jg(), a&(1 To 6), b&(9), m&, n&, k&
  2. Sub test() 'by kagawa 2015/2/17
  3.     tms = Timer
  4.     m = [a1].End(4).Row '获取A列最大行数 即需检查的3位数个数
  5.     ReDim sj(1 To m, 0 To 3) '定义存放原始数据的数组sj
  6.     For i = 1 To m
  7.         t = Right("000" & Cells(i, 1), 3) '3位数标准化
  8.         sj(i, 0) = "'" & t  '返回单元格时需要单引号强制转为文本字符串格式
  9.         For j = 1 To 3
  10.             sj(i, j) = Mid(t, j, 1) '拆分每个3位数 这样预处理一下可以提高后面的计算速度
  11.         Next
  12.     Next
  13.    
  14.     ReDim jg(1 To 65536, 1 To 6): k = 0 '定义存放满足条件6组3位数结果的数组jg

  15.     Call dgZH(0, 1)    '调用递归组合算法过程

  16.     [d6].CurrentRegion = "": [d6].Resize(k, 6) = jg '输出结果到工作表
  17.     MsgBox Format(Timer - tms, "0.000s ") & k       '程序耗时和结果总数k
  18. End Sub

  19. Sub dgZH(i&, t&) '递归算法过程
  20.     Dim j&, l&, n&, r&, s$
  21.     For j = i + 1 To m - 6 + t
  22.         For l = 1 To 3
  23.             n = sj(j, l)
  24.             b(n) = b(n) + 1 'b数组记录0-9数字出现个数
  25.         Next
  26.         a(t) = j
  27.         If t = 6 Then '组合数达到6个时
  28.             For l = 0 To 9
  29.                 If b(l) Then If b(l) <> 2 Then Exit For '检查0-9出现次数符合=2
  30.             Next
  31.             If l = 10 Then '如检查0-9出现次数都符合=2 或=0则OK
  32.                 k = k + 1
  33.                 For l = 1 To 6
  34.                     jg(k, l) = sj(a(l), 0) '本次6个3位数组合有效,记录到数组jg中
  35.                 Next
  36.             End If
  37.         Else
  38.             Call dgZH(j, t + 1) '组合不足6个时继续下一个组合
  39.         End If
  40.         For l = 1 To 3
  41.             n = sj(j, l)
  42.             b(n) = b(n) - 1 '该3位数组合使用完毕后 需要从数组b中扣去0-9出现次数
  43.         Next
  44.     Next
  45. End Sub
复制代码
呵呵,我的算法才是厉害的。

Chk 6.zip

19.29 KB, 下载次数: 26

评分

参与人数 2 +11 收起 理由
zpy2 + 1 璧炰竴涓
dsmch + 10 牛叉

查看全部评分

回复

使用道具 举报

发表于 2015-2-17 15:09 | 显示全部楼层
本帖最后由 dsmch 于 2015-2-17 15:34 编辑

用递归尝试一下
  1. Dim arr, brr, n%, s&
  2. Sub Macro1()
  3. t = Timer
  4. ReDim brr(1 To 60000, 1 To 6)
  5. s = 0: n = 6
  6. arr = [a1:ae1]
  7. zuhe 1, "", 0
  8. Range("a4").Resize(20000, 6) = ""
  9. Range("a4").Resize(s, 6) = brr
  10. MsgBox Timer - t
  11. End Sub
  12. Sub zuhe(h, zf, t)
  13. Dim w(9)
  14. If t = n Then
  15.     s2 = 0
  16.     For i = 1 To 18
  17.         z = Mid(zf, i, 1)
  18.         w(z) = w(z) + 1
  19.         If w(z) = 2 Then s2 = s2 + 1
  20.     Next
  21.     If s2 = 9 Then
  22.         s = s + 1: n2 = 0
  23.         For j = 1 To 16 Step 3
  24.             n2 = n2 + 1
  25.             brr(s, n2) = Mid(zf, j, 3)
  26.         Next
  27.     End If
  28.     Exit Sub
  29. End If
  30. If h < UBound(arr, 2)+1 Then
  31.     zuhe h + 1, zf & arr(1, h), t + 1
  32.     zuhe h + 1, zf, t
  33. End If
  34. End Sub
复制代码

评分

参与人数 1 +1 收起 理由
zpy2 + 1 璧炰竴涓

查看全部评分

回复

使用道具 举报

发表于 2015-2-20 19:03 | 显示全部楼层
dsmch 发表于 2015-2-17 15:09
用递归尝试一下

为毛你的递归代码速度还是那么慢……呵呵。看来不是递归的问题。
回复

使用道具 举报

您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2024-3-29 22:29 , Processed in 0.391054 second(s), 17 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

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