ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

EH搜索     
EH云课堂-专业的职场技能充电站 Excel转在线管理系统,怎么做看这里 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
Excel不给力? 何不试试FoxTable! Excel 2016函数公式学习大典 EH云课堂直播课程免费学 打造核心竞争力的职场宝典
300集Office 2010微视频教程 Tableau-数据可视化工具 精品推荐-800套精选PPT模板,点击获取 ExcelHome出品 - VBA代码宝免费下载
你的Excel 2010实战技巧学习锦囊 欲罢不能, 过目难忘的 Office 新界面 Excel VBA经典代码实践指南
查看: 4650|回复: 21

[求助] 规求vba解数独游戏的源码

[复制链接]

TA的精华主题

TA的得分主题

发表于 2013-10-14 15:04 | 显示全部楼层 |阅读模式
本帖已被收录到知识树中,索引项:递归
需求:
1.用excel自带的vba窗体的方式展现游戏界面
2.将1到9这9个数字按一定秩序填入每行(从左至右)、每列(从上至下)、每个小九宫格(内有9个小方格),每个数字在每行、每列、每个小九宫格中只能出现一次。

谢谢啦!!!

点评

知识树内容索引:10楼  发表于 2013-10-16 21:21

TA的精华主题

TA的得分主题

 楼主| 发表于 2013-10-14 15:07 | 显示全部楼层
亲们、最好能提供代码注释、因为是初学者、没有注释看不懂。非常感谢!

TA的精华主题

TA的得分主题

发表于 2013-10-14 15:41 | 显示全部楼层
坛子里只有人贴过暴力计算的,没有AI可言。估计你看了也是白看~

自己搜索一下~

TA的精华主题

TA的得分主题

发表于 2013-10-15 11:05 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2013-10-15 11:31 | 显示全部楼层
lee1892 发表于 2013-10-14 15:41
坛子里只有人贴过暴力计算的,没有AI可言。估计你看了也是白看~

自己搜索一下~

估计不可能按照 9 x 9 = 81 的全排列进行暴力计算……

一共有Fact(81)=5.79712602074737E+120 种排列组合方式。

即:
5797126020747367985879734231578109105412357244731625958745865049716390179693892056256184534249745940480000000000000000000

所以不可能是暴力破解算法。


…………
应该是循环试算+剪枝的算法。
虽然不会是智能解法,但也很有些技术含量了。


TA的精华主题

TA的得分主题

发表于 2013-10-15 11:45 | 显示全部楼层
其实,我倒是研究过按照数独规则的智能算法。

但有2个缺点:
1. 有时候会无解。
  a. 当某些位置成对可以互换时,可以选一个继续,但也容易造成试算错误无解
  b. 某些高级智能太复杂难以写成代码
  c. 真的解不出(必须从多个可能性中试一试)

2. 计算速度比【自动试算+剪枝】的【伪暴力算法】更慢。


呵呵。

TA的精华主题

TA的得分主题

发表于 2013-10-15 11:52 | 显示全部楼层
以下是我的智能算法代码:

九宫格数据填写在B2:J10的区域里。
  1. Sub Answer()
  2.   Dim A%, p%, t1, t2, Sj0, Sj1
  3.   t1 = Timer
  4.   Sj = [datas]
  5.   Sj0 = Sj
  6.   Do
  7.     A = AllCross(Sj)
  8.     If A = 81 Then
  9.       [datas] = Sj
  10.       t2 = Timer
  11.       [p11] = t2 - t1
  12.       'MsgBox Format(t2 - t1, "0.000 S")
  13.       Exit Sub
  14.     ElseIf A = -1 Then
  15.       Sj = Sj0
  16.       p = p + 1
  17.       GoTo ValidTest
  18.     Else
  19.       Sj1 = Sj
  20.       p = 1
  21. ValidTest:
  22.       If GetValid(Sj, p) = 0 Then
  23.         Sj = Sj0
  24.         p = p + 1
  25.         GoTo ValidTest
  26.       Else
  27.         Sj0 = Sj1
  28.       End If
  29.     End If
  30.    
  31.   Loop
  32. End Sub
  33. Function AllCross(ByRef Sj As Variant) As Integer
  34.   Dim i%, j%, K%, kk%, Sj1, GetSome As Boolean
  35.   'Sj = [datas]
  36.   Do
  37.     GetSome = False
  38.     For kk = 1 To 9
  39.       Sj1 = Sj
  40.       For i = 1 To 9
  41.         For j = 1 To 9
  42.           If Sj(i, j) = kk Then
  43.             For K = 1 To 9
  44.               Sj1(i, K) = 1
  45.               Sj1(K, j) = 1
  46.               Sj1(((i - 1) \ 3) * 3 + 1 + (K - 1) \ 3, ((j - 1) \ 3) * 3 + 1 + (K - 1) Mod 3) = 1
  47.             Next K
  48.           ElseIf Sj(i, j) >= 1 And Sj(i, j) <= 9 Then
  49.             Sj1(i, j) = 1
  50.           End If
  51.         Next j
  52.       Next i
  53.    
  54.       For i = 1 To 9
  55.         For j = 1 To 9
  56.           If Sj1(i, j) = "" Then
  57.             R = 0
  58.             C = 0
  59.             D = 0
  60.             For K = 1 To 9
  61.               R = R + Val(Sj1(i, K))
  62.               C = C + Val(Sj1(K, j))
  63.               D = D + Val(Sj1(((i - 1) \ 3) * 3 + 1 + (K - 1) \ 3, ((j - 1) \ 3) * 3 + 1 + (K - 1) Mod 3))
  64.             Next K
  65.             
  66.             If R = 8 Or C = 8 Or D = 8 Then
  67.               Sj(i, j) = kk
  68.               GetSome = True
  69.             End If
  70.             
  71.           End If
  72.         Next j
  73.       Next i
  74.    
  75.     Next kk
  76.   Loop While GetSome
  77.   
  78.   
  79.   For i = 1 To 9
  80.     R = 0
  81.     For j = 1 To 9
  82.       If Len(Sj(i, j)) <> 1 Then
  83.         GoTo RNext
  84.       Else
  85.         R = R + Sj(i, j)
  86.       End If
  87.     Next j
  88.     If R <> 45 Then GoTo Ext
  89. RNext:
  90.   Next i
  91.   
  92.   For i = 1 To 9
  93.     C = 0
  94.     For j = 1 To 9
  95.       If Len(Sj(j, i)) <> 1 Then
  96.         GoTo CNext
  97.       Else
  98.         C = C + Sj(j, i)
  99.       End If
  100.     Next j
  101.     If C <> 45 Then GoTo Ext
  102. CNext:
  103.   Next i
  104.   
  105.   For K = 0 To 8
  106.     D = 0
  107.     For i = 0 To 2
  108.       For j = 0 To 2
  109.         If Len(Sj(i + (K \ 3) * 3 + 1, j + (K Mod 3) * 3 + 1)) <> 1 Then
  110.           GoTo DNext
  111.         Else
  112.           D = D + Sj(i + (K \ 3) * 3 + 1, j + (K Mod 3) * 3 + 1)
  113.         End If
  114.       Next j
  115.     Next i
  116.     If D <> 45 Then GoTo Ext
  117. DNext:
  118.   Next K
  119.   
  120.   AllCross = 0
  121.   For i = 1 To 9
  122.     For j = 1 To 9
  123.       If Len(Sj(i, j)) = 1 Then AllCross = AllCross + 1
  124.     Next j
  125.   Next i
  126. Exit Function

  127. Ext:
  128.   AllCross = -1
  129. End Function
  130. Function GetValid(ByRef Sj As Variant, ByRef p As Integer) As Integer
  131.   Dim i%, j%, K%, l&, S$, Sj1
  132.   Sj1 = Sj
  133.   l = 9
  134.   For i = 1 To 9
  135.     For j = 1 To 9
  136.       If Sj(i, j) = "" Then
  137.         S = "123456789"
  138.         For K = 1 To 9
  139.           S = Replace(S, Sj(i, K), "")
  140.           S = Replace(S, Sj(K, j), "")
  141.           S = Replace(S, Sj(((i - 1) \ 3) * 3 + 1 + (K - 1) \ 3, ((j - 1) \ 3) * 3 + 1 + (K - 1) Mod 3), "")
  142.         Next K
  143.         
  144.         Sj1(i, j) = S
  145.         If Len(S) = 0 Then Exit Function
  146.         
  147.         If Len(S) < l Then
  148.           If Len(S) = 1 Then
  149.             Sj(i, j) = S
  150.             GetValid = 1
  151.             Exit Function
  152.           Else
  153.             l = Len(S)
  154.           End If
  155.         End If
  156.         
  157.       End If
  158.     Next j
  159.   Next i
  160.   
  161.   For i = 1 To 9
  162.     For j = 1 To 9
  163.       If Len(Sj1(i, j)) = l Then
  164.         Sj(i, j) = Mid(Sj1(i, j), p, 1)
  165.         GetValid = p
  166.         Exit Function
  167.       End If
  168.     Next j
  169.   Next i
  170.   GetValid = 0
  171. End Function
复制代码
代码注释就不给了。

New Sudoku.zip

32.63 KB, 下载次数: 149

TA的精华主题

TA的得分主题

发表于 2013-10-15 12:00 | 显示全部楼层
香川群子 发表于 2013-10-15 11:31
估计不可能按照 9 x 9 = 81 的全排列进行暴力计算……

一共有Fact(81)=5.79712602074737E+120 种排列组 ...

循环试算不是暴力是啥?

其实,我倒是研究过按照数独规则的智能算法。

但有2个缺点:
1. 有时候会无解。
  a. 当某些位置成对可以互换时,可以选一个继续,但也容易造成试算错误无解
  b. 某些高级智能太复杂难以写成代码
  c. 真的解不出(必须从多个可能性中试一试)

2. 计算速度比【自动试算+剪枝】的【伪暴力算法】更慢。


估计:
1、你对数独的高级技巧掌握的不够丰富
2、到目前我做过的数以千的高难度数独中,只碰到过一个必须反复多次使用暴力试算的办法的,其它最多一两个格子需要这么干的。所以还是回到1,呵呵
3、暴力计算当然快,模拟人脑按游戏的内在逻辑推理计算才是有意思的地方
4、神经网络算法应该可以应用,不知道速度上比暴力计算如何~

点评

不是我不掌握高级技巧,而是我没有能力把高级智能技巧写成代码……呵呵。  发表于 2013-10-15 20:10

TA的精华主题

TA的得分主题

发表于 2013-10-15 12:04 | 显示全部楼层
我的智能算法只引入了两种基本算法:

1. 交叉确认唯一性。
反复循环1-9,按行、列、宫检查排除后确定得到唯一性值,代入后继续循环,
直至循环不能产生新的解为止

2. 行、列、宫检查计算本位置可能出现的值,如果是具有唯一性的值就填入

3. 对于无法由上述1、2计算得到正确的唯一解的空单元格,采取填入第一个可能值进行测试。


…………
毫无疑问,以上算法经常会有错误无解的情况,但大部分也可以轻松地计算出结果来。呵呵。


TA的精华主题

TA的得分主题

发表于 2013-10-16 19:00 | 显示全部楼层
写了个递归计算的暴力破解代码:
  1. Dim m&, cnt1&, cnt2&
  2. Sub shudu_kagawa() '主程序
  3.     Dim i&, j&, n&, t&
  4.     tms = Timer
  5.    
  6.     sj0 = [data]
  7. '    [b12].Resize(9, 9) = sj0
  8.     ReDim sj(80)
  9.     For i = 0 To 8
  10.         For j = 0 To 8
  11.             t = sj0(i + 1, j + 1): If t Then sj(i * 9 + j) = t: n = n + 1
  12.         Next
  13.     Next
  14.     '以上为原始数据转为一维数组数据

  15.     m = 0: cnt1 = 0: cnt2 = 0
  16.     Call sim(sj, n) '调用递归计算过程
  17.    
  18.     [b24] = Format(Timer - tms, "0.000s ") & cnt1 & "/" & cnt2
  19.     MsgBox Format(Timer - tms, "0.000s ") & cnt1 & "/" & cnt2
  20. End Sub

  21. Sub sim(ByVal sj, ByVal n&) '递归计算过程代码
  22.     Dim i&, k&, k1&, t1$
  23.     If m = 81 Then Exit Sub
  24.     Do
  25.         m = 0
  26.         For k = 0 To 80
  27.             If sj(k) = 0 Then
  28.                 t1 = sim1(sj, k)
  29.                 If t1 = "" Then Exit Sub Else If Len(t1) = 1 Then sj(k) = t1: m = m + 1
  30.             End If
  31.         Next
  32.         If m Then n = m + n Else Exit Do
  33.     Loop
  34.     If n = 81 Then Call Output(sj): m = 81: Exit Sub
  35.     '以上为Do……Loop循环按唯一性原则填入有效数,直至81个数全部填满时退出
  36.    
  37.     For k = 0 To 80
  38.         If sj(k) = 0 Then k1 = k: t1 = sim1(sj, k): Exit For
  39.     Next
  40.     '以上为检查第一个可以有多个数待选的空位置
  41.     For i = 1 To Len(t1)
  42.         cnt1 = cnt1 + 1
  43.         sj1 = sj
  44.         sj1(k1) = Mid(t1, i, 1) '此位置从候选数中循环取1个进行赋值
  45.         Call sim(sj1, n + 1) '然后递归进行深度计算
  46.     Next
  47.     If m = 81 Then Exit Sub
  48. End Sub

  49. Function sim1$(ByVal sj1, ByVal k1) '检查某个位置候选数的函数代码
  50.     Dim i&, j&, k&, i1&, j1&, s$
  51.     cnt2 = cnt2 + 1
  52.     s$ = "123456789"
  53.     i1 = k1 \ 9
  54.     For j = 0 To 8
  55.         s = Replace(s, sj1(i1 * 9 + j), "") '检查同一行
  56.     Next
  57.     j1 = k1 Mod 9
  58.     For i = 0 To 8
  59.         s = Replace(s, sj1(i * 9 + j1), "") '检查同一列
  60.     Next
  61.     i1 = i1 \ 3: j1 = j1 \ 3
  62.     For k = 0 To 80
  63.         If (k \ 9) \ 3 = i1 And (k Mod 9) \ 3 = j1 Then s = Replace(s, sj1(k), "")
  64.         '检查同一宫内
  65.     Next
  66.     sim1 = s
  67. End Function

  68. Sub Output(sj1) '把计算完成的一维数组结果转换为九宫格后输出
  69.     Dim sj2(8, 8), k&
  70.     For k = 0 To 80
  71.         sj2(k \ 9, k Mod 9) = sj1(k)
  72.     Next
  73.     [b12].Resize(9, 9) = sj2
  74. End Sub
复制代码
使用一维数组是为了让代码看上去简单一些。
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

关注官方微信,高效办公专列,每天发车

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

GMT+8, 2019-10-17 23:16 , Processed in 0.079242 second(s), 16 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2020 Wooffice Inc.

   

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

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

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