vba实现解数独题目

meishayongle

直接上代码

1. 模块

复制代码

主程序

1. Sub MainStart()
   
2. Dim Kcell, Row, Col, k As Integer 'Kcell-非空单元格个数,等于81时表示填写完毕
   
3. Dim Result As Boolean
   
4. Kcell = 1
   
5. Sheet3.Range("E1").Value = 1 '记录缓存队列的位置
   
6. Sheet3.Range("E2") = 0 '此格子的数字表示是否有过缓存。0没有，1有
   
7. SetFontColor '设置原有内容的颜色
   
8. Sheet3.Range("A:C").ClearContents
   
9. t = Timer
   
10. 
    
11. For Row = 1 To 9 '逐个格子进行循环，行
    
12.     For Col = 1 To 9 '逐个格子进行循环，列
    
13.         If Sheet1.Cells(Row, Col) = "" Then '如果格子为空，则试着填入某个数字
    
14.             Result = RC_RANGE(Row, Col, 1) '返回结果为真，表示可填写
    
15.             If Result Then '结果为真，判断是否完成解题
    
16.                 Kcell = WorksheetFunction.CountA(Range("A1:I9")) '获取非空单元格个数
    
17.                 If Kcell = 81 Then
    
18.                     MsgBox "解题完成，耗时:" & Timer - t
    
19.                 End If
    
20.                 If Sheet3.Range("E1").Value = 1 And Sheet3.Range("E2").Value = 1 And Sheet3.Range("A1") = "" Then
    
21.                     MsgBox "此数独无解！"
    
22.                     End
    
23.                 End If
    
24.                 k = Sheet3.Range("E1").Value - 1
    
25.                 Row = Sheet3.Cells(k, 1)
    
26.                 Col = Sheet3.Cells(k, 2)
    
27.             Else '返回结果假则无解
    
28.                 MsgBox "此数独无解！"
    
29.             End If
    
30.         End If
    
31.     Next Col
    
32. Next Row
    
33. End Sub
    
34. 
    
35. Sub SetFontColor() '设置字体颜色
    
36. 
    
37. Dim i, j As Integer
    
38. 
    
39. i = j = 1
    
40. 
    
41. Sheet1.Range("a1:i9").Font.Color = vbBlack '设置字体为黑色
    
42. 
    
43. For i = 1 To 9
    
44. 
    
45.     For j = 1 To 9
    
46.         
    
47.         If Sheet1.Cells(i, j) <> "" Then
    
48.         
    
49.             Sheet1.Cells(i, j).Font.Color = vbRed '设置字体为红色
    
50.             
    
51.         End If
    
52.         
    
53.     Next
    
54.    
    
55. Next
    
56. 
    
57. End Sub

复制代码

meishayongle

1. Function RC_RANGE(ByVal r As Integer, ByVal c As Integer, ByVal p As Integer) As Boolean '判断是否可填入数字,p为将要填写的数字
   
2. Dim a1, a2, a3 As Integer
   
3. Dim Result1 As Boolean
   
4. a1 = 0 '标记宫是否可填入
   
5. a2 = 0 '标记r行是否可填入
   
6. a3 = 0 '标记宫c列否可填入
   
7. '1
   
8. If 1 <= r And r <= 3 And 1 <= c And c <= 3 Then '1宫
   
9.     a1 = Application.WorksheetFunction.CountIf(Sheet1.Range("A1:C3"), p)
   
10.     a2 = Application.WorksheetFunction.CountIf(Sheet1.Range("A" & r & ":" & "I" & r), p)
    
11.     a3 = Application.WorksheetFunction.CountIf(Sheet1.Range(Mid(Cells(r, c).Address, 2, 1) & "1" & ":" & Mid(Cells(r, c).Address, 2, 1) & "9"), p)
    
12.     If (a1 + a2 + a3) = 0 Then
    
13.         RC_RANGE = True
    
14.     Else
    
15.         RC_RANGE = False
    
16.     End If
    
17. End If
    
18. '2
    
19. If 1 <= r And r <= 3 And 4 <= c And c <= 6 Then '2宫
    
20.     a1 = Application.WorksheetFunction.CountIf(Sheet1.Range("D1:F3"), p)
    
21.     a2 = Application.WorksheetFunction.CountIf(Sheet1.Range("A" & r & ":" & "I" & r), p)
    
22.     a3 = Application.WorksheetFunction.CountIf(Sheet1.Range(Mid(Cells(r, c).Address, 2, 1) & "1" & ":" & Mid(Cells(r, c).Address, 2, 1) & "9"), p)
    
23.     If (a1 + a2 + a3) = 0 Then
    
24.         RC_RANGE = True
    
25.     Else
    
26.         RC_RANGE = False
    
27.     End If
    
28. End If
    
29. '3
    
30. If 1 <= r And r <= 3 And 7 <= c And c <= 9 Then '3宫
    
31.     a1 = Application.WorksheetFunction.CountIf(Sheet1.Range("G1:I3"), p)
    
32.     a2 = Application.WorksheetFunction.CountIf(Sheet1.Range("A" & r & ":" & "I" & r), p)
    
33.     a3 = Application.WorksheetFunction.CountIf(Sheet1.Range(Mid(Cells(r, c).Address, 2, 1) & "1" & ":" & Mid(Cells(r, c).Address, 2, 1) & "9"), p)
    
34.     If (a1 + a2 + a3) = 0 Then
    
35.         RC_RANGE = True
    
36.     Else
    
37.         RC_RANGE = False
    
38.     End If
    
39. End If
    
40. '4
    
41. If 4 <= r And r <= 6 And 1 <= c And c <= 3 Then '4宫
    
42.     a1 = Application.WorksheetFunction.CountIf(Sheet1.Range("A4:C6"), p)
    
43.     a2 = Application.WorksheetFunction.CountIf(Sheet1.Range("A" & r & ":" & "I" & r), p)
    
44.     a3 = Application.WorksheetFunction.CountIf(Sheet1.Range(Mid(Cells(r, c).Address, 2, 1) & "1" & ":" & Mid(Cells(r, c).Address, 2, 1) & "9"), p)
    
45.     If (a1 + a2 + a3) = 0 Then
    
46.         RC_RANGE = True
    
47.     Else
    
48.         RC_RANGE = False
    
49.     End If
    
50. End If
    
51. '5
    
52. If 4 <= r And r <= 6 And 4 <= c And c <= 6 Then  '5宫
    
53.     a1 = Application.WorksheetFunction.CountIf(Sheet1.Range("D4:F6"), p)
    
54.     a2 = Application.WorksheetFunction.CountIf(Sheet1.Range("A" & r & ":" & "I" & r), p)
    
55.     a3 = Application.WorksheetFunction.CountIf(Sheet1.Range(Mid(Cells(r, c).Address, 2, 1) & "1" & ":" & Mid(Cells(r, c).Address, 2, 1) & "9"), p)
    
56.     If (a1 + a2 + a3) = 0 Then
    
57.         RC_RANGE = True
    
58.     Else
    
59.         RC_RANGE = False
    
60.     End If
    
61. End If
    
62. '6
    
63. If 4 <= r And r <= 6 And 7 <= c And c <= 9 Then '6宫
    
64.     a1 = Application.WorksheetFunction.CountIf(Sheet1.Range("G4:I6"), p)
    
65.     a2 = Application.WorksheetFunction.CountIf(Sheet1.Range("A" & r & ":" & "I" & r), p)
    
66.     a3 = Application.WorksheetFunction.CountIf(Sheet1.Range(Mid(Cells(r, c).Address, 2, 1) & "1" & ":" & Mid(Cells(r, c).Address, 2, 1) & "9"), p)
    
67.     If (a1 + a2 + a3) = 0 Then
    
68.         RC_RANGE = True
    
69.     Else
    
70.         RC_RANGE = False
    
71.     End If
    
72. End If
    
73. '7
    
74. If 7 <= r And r <= 9 And 1 <= c And c <= 3 Then  '7宫
    
75.     a1 = Application.WorksheetFunction.CountIf(Sheet1.Range("A7:C9"), p)
    
76.     a2 = Application.WorksheetFunction.CountIf(Sheet1.Range("A" & r & ":" & "I" & r), p)
    
77.     a3 = Application.WorksheetFunction.CountIf(Sheet1.Range(Mid(Cells(r, c).Address, 2, 1) & "1" & ":" & Mid(Cells(r, c).Address, 2, 1) & "9"), p)
    
78.     If (a1 + a2 + a3) = 0 Then
    
79.         RC_RANGE = True
    
80.     Else
    
81.         RC_RANGE = False
    
82.     End If
    
83. End If
    
84. '8
    
85. If 7 <= r And r <= 9 And 4 <= c And c <= 6 Then '8宫
    
86.     a1 = Application.WorksheetFunction.CountIf(Sheet1.Range("D7:F9"), p)
    
87.     a2 = Application.WorksheetFunction.CountIf(Sheet1.Range("A" & r & ":" & "I" & r), p)
    
88.     a3 = Application.WorksheetFunction.CountIf(Sheet1.Range(Mid(Cells(r, c).Address, 2, 1) & "1" & ":" & Mid(Cells(r, c).Address, 2, 1) & "9"), p)
    
89.     If (a1 + a2 + a3) = 0 Then
    
90.         RC_RANGE = True
    
91.     Else
    
92.         RC_RANGE = False
    
93.     End If
    
94. End If
    
95. '9
    
96. If 7 <= r And r <= 9 And 7 <= c And c <= 9 Then '9宫
    
97.     a1 = Application.WorksheetFunction.CountIf(Sheet1.Range("G7:I9"), p)
    
98.     a2 = Application.WorksheetFunction.CountIf(Sheet1.Range("A" & r & ":" & "I" & r), p)
    
99.     a3 = Application.WorksheetFunction.CountIf(Sheet1.Range(Mid(Cells(r, c).Address, 2, 1) & "1" & ":" & Mid(Cells(r, c).Address, 2, 1) & "9"), p)
    
100.     If (a1 + a2 + a3) = 0 Then
     
101.         RC_RANGE = True
     
102.     Else
     
103.         RC_RANGE = False
     
104.     End If
     
105. End If
     
106. Result1 = RC_RANGE
     
107. 
     
108. '判断返回的结果，如果结果为假，说明当前数字不可填入，继续填写下一个数字直到9
     
109. '如果结果为真，则填入当前数字，并在sheet2中记录当前单元格的行列和填写的值
     
110. '如果到9也不可填入，说明无解
     
111. If Result1 = False Then '如果结果为假，即当前数字不可填入，则数字p加1，回调直到9为止
     
112.     p = p + 1
     
113.     'If p = 10 Then '说明没有数字可以填写，让程序返回上一个格子重新填写
     
114.         'RC_RANGE = False
     
115.         'Exit Function
     
116.         'Sheet3.Range("E1").Value = Sheet3.Range("E1").Value - 1
     
117.         'm = Sheet3.Range("E1").Value
     
118.         'r = Sheet3.Cells(m, 1)
     
119.         'c = Sheet3.Cells(m, 2)
     
120.         'p = Sheet3.Cells(m, 3)
     
121.         'Sheet3.Range("a" & p & ":" & "c" & p).ClearContents '清除当前缓存队列
     
122.         'Sheet1.Cells(r, c).ClearContents
     
123.         'If m = 1 And Sheet3.Range("E2").Value = 1 Then
     
124.         '    Result1 = False
     
125.         '    Exit Function
     
126.         'End If
     
127.         'Result1 = RC_RANGE(r, c, p + 1) '此处p可能会增加到10，需要判断此类情况
     
128.     'End If
     
129.     Result1 = RC_RANGE(r, c, p)
     
130. ElseIf Result1 = True And p <> 10 Then '结果为真，填写数字并记录行列和值的信息，并结束次过程，并返回结果真，让住程序填写下一个格子
     
131.     Sheet1.Cells(r, c) = p '填写数字
     
132.     Sheet3.Cells(Sheet3.Range("E1").Value, 1) = r '记录行
     
133.     Sheet3.Cells(Sheet3.Range("E1").Value, 2) = c '记录列
     
134.     Sheet3.Cells(Sheet3.Range("E1").Value, 3) = p '记录填写的值
     
135.     Sheet3.Range("E1") = Sheet3.Range("E1").Value + 1
     
136.     Sheet3.Range("E2") = 1
     
137.     'RC_RANGE = True
     
138.     Exit Function
     
139. ElseIf Result1 = True And p = 10 Then '在第一次为假的时候，可能P会加到10，所以要判断这种情况
     
140.     Sheet3.Range("E1").Value = Sheet3.Range("E1").Value - 1
     
141.     m = Sheet3.Range("E1").Value
     
142.     r = Sheet3.Cells(m, 1)
     
143.     c = Sheet3.Cells(m, 2)
     
144.     p = Sheet3.Cells(m, 3)
     
145.     Sheet3.Range("a" & m & ":" & "c" & m).ClearContents '清除当前缓存队列
     
146.     Sheet1.Cells(r, c).ClearContents
     
147.     If m = 1 And Sheet3.Range("E2").Value = 1 Then
     
148.         Result1 = False
     
149.         Exit Function
     
150.     End If
     
151.     Result1 = RC_RANGE(r, c, p + 1)
     
152. End If
     
153. RC_RANGE = Result1
     
154. End Function
     

复制代码

发现模块的代码没贴上，现在重贴

MY→Email

确实厉害了。

huanghai22

这道题算到卡死都没解开

micch

真厉害2015年的帖子，没人回，2019年翻出来了
哪位数学好的做一下，我做了一下午，最后只能遍历去解题，发现楼上是无解的，但不知道如何证明

ryueifu2

大家可以计算一下这道题
..53.....8......2..7..1.5..4....53...1..7...6..32...8..6.5....9..4....3......97..

我在六七年前上传了一个文档，里面全是数独题目，大家下载看看：
https://wenku.baidu.com/view/d149d91cfc4ffe473368ab23.html

ryueifu2

我也分享一个数独求解和生成工具：

ryueifu2

huanghai22 发表于 2019-2-17 14:48
这道题算到卡死都没解开

你这道题的答案是：

yangyangzhifeng

ryueifu2 发表于 2019-2-18 20:11
我也分享一个数独求解和生成工具：

暴力解法有点慢，vb的话应该毫秒级，c语言的话应该微妙级

投融世界

有道数独，楼上的VB给出无解的执行结果，那个工具解出来，谢谢大神。