数独游戏

bajifeng

第10部分：

1. Private Function m_ValueInUse(Cell As Integer, Value As Integer) As Boolean
   
2. '
   
3. ' Check whether value has already been used in same row or column
   
4. ' use this before trying to solve a user puzzle
   
5. '
   
6.     Dim intRow As Integer
   
7.     Dim intCol As Integer
   
8.    
   
9.     intRow = m_WhichSubRow(Cell)
   
10.     intCol = m_WhichSubCol(Cell)
    
11.         
    
12.     m_ValueInUse = (m_ValueInRow(intRow, Value) + m_ValueInCol(intCol, Value)) > 2
    
13.    
    
14.    
    
15. End Function
    
16. 
    
17. Sub sudoku_About()
    
18. '
    
19. ' Display about info on Su Doku.
    
20. '
    
21.     Dim strMsg As String
    
22.    
    
23.     strMsg = SUDOKU_TITLE & SUDOKU_VERSION & " Written by " & SUDOKU_AUTHOR & vbLf & vbLf
    
24.     strMsg = strMsg & "Rules:" & vbLf
    
25.     strMsg = strMsg & "To solve a Su Doku puzzle every digit from 1 to 9 must appear in " & vbLf
    
26.     strMsg = strMsg & "each of the 9 columns and 9 rows" & vbLf
    
27.     strMsg = strMsg & "AND within each of the 9 boxes." & vbLf & vbLf
    
28.     strMsg = strMsg & "You can generate random puzzles or solve user entered puzzles." & vbLf & vbLf
    
29.     strMsg = strMsg & "Clear Grid - " & vbTab & vbTab & "clear the contents of the grid" & vbLf
    
30.     strMsg = strMsg & "New Puzzle -" & vbTab & vbTab & "generates a unique puzzle" & vbLf
    
31.     strMsg = strMsg & "Reveal Puzzle -" & vbTab & vbTab & "reveals solution to puzzle" & vbLf
    
32.     strMsg = strMsg & "Solve YOUR Puzzle -" & vbTab & "attempts to solve puzzle entered by you" & vbLf
    
33. 
    
34.     MsgBox strMsg, vbInformation, "About " & SUDOKU_TITLE
    
35.    
    
36. End Sub
    
37. Private Sub m_ClearDisplay()
    
38. '
    
39. ' Clear display
    
40. '
    
41.     Dim rngGrid As Range
    
42.    
    
43.     m_ProtectPuzzle False
    
44.    
    
45.     ' clear display
    
46.     Set rngGrid = m_AssignDisplay()
    
47.     With rngGrid
    
48.         .ClearContents
    
49.         .Font.Bold = False
    
50.         .Locked = False
    
51.     End With
    
52.    
    
53.     m_ProtectPuzzle True
    
54.         
    
55. End Sub
    
56. Sub sudoku_ClearPuzzle()
    
57. '
    
58. ' Clear puzzle grids and leave grid ready to receive puzzle
    
59. '
    
60.     m_ClearDisplay
    
61.     m_ClearStorage
    
62.     m_ProtectPuzzle True
    
63.    
    
64. End Sub
    
65. Private Sub m_ClearStorage()
    
66. '
    
67. ' Clear storage grid
    
68. '
    
69.     Dim rngGrid As Range
    
70.    
    
71.     m_ProtectPuzzle False
    
72.    
    
73.     ' clear grid
    
74.     Set rngGrid = m_AssignStorage()
    
75.     With rngGrid
    
76.         .ClearContents
    
77.         .Font.Bold = False
    
78.         .Locked = False
    
79.     End With
    
80.    
    
81.     m_ProtectPuzzle True
    
82.         
    
83. End Sub

复制代码

bajifeng

第11部分：

1. Sub sudoku_Puzzle()
   
2. '
   
3. ' Generate a puzzle
   
4. '
   
5.     Dim intRow As Integer
   
6.     Dim intCol As Integer
   
7.     Dim intIndex As Integer
   
8.     Dim intCell As Integer
   
9.     Dim lngRow As Long
   
10.     Dim rngTemp As Range
    
11.     Dim rngGrid As Range
    
12.    
    
13.     Application.ScreenUpdating = False
    
14.     Application.StatusBar = SUDOKU_MSG_BUILDPUZZLE
    
15.    
    
16.     Do
    
17.         sudoku_ClearPuzzle                  ' clear display and storage areas
    
18.         m_ResetPuzzleArrays                 ' reset variables
    
19.         m_ProtectPuzzle False
    
20.         Randomize                           ' set random number generator
    
21.         m_StartingGrid                      ' begin grid creation
    
22.     Loop While Not m_CompleteGrid()         ' complete the solution to this grid
    
23.    
    
24.     ' output numbers to storage grid
    
25.     Set rngGrid = m_AssignStorage
    
26.     For Each rngTemp In rngGrid
    
27.         intCell = intCell + 1
    
28.         If m_intGrid(intCell, 0) <> 0 Then
    
29.             rngTemp = m_intGrid(intCell, 0)
    
30.         End If
    
31.     Next
    
32.    
    
33.     m_GetUniqueSolution       ' random select starting values
    
34.    
    
35.     Set rngGrid = m_AssignDisplay
    
36.     With rngGrid
    
37.         .HorizontalAlignment = xlCenter
    
38.         .VerticalAlignment = xlCenter
    
39.     End With
    
40.     m_ProtectPuzzle True        ' lock starting cells
    
41.    
    
42.     Application.ScreenUpdating = True
    
43.     Application.StatusBar = False
    
44.    
    
45. End Sub
    
46. Sub sudoku_RevealPuzzle()
    
47. '
    
48. ' show solution to puzzle or solve user supplied puzzle
    
49. '
    
50.     Dim lngChoice As Long
    
51.    
    
52.     Application.ScreenUpdating = False
    
53.    
    
54.     If Not m_IsUserPuzzle() Then
    
55.         ' The grid matches current solution so simply
    
56.         ' transfer solution
    
57.         m_RevealPuzzle
    
58.     Else
    
59.         lngChoice = MsgBox(SUDOKU_MSG_USERPUZZLE, vbYesNoCancel Or vbQuestion)
    
60.         If lngChoice = vbYes Then
    
61.             ' confirm this is what they want
    
62.             m_SolvePuzzle
    
63.         ElseIf lngChoice = vbNo Then
    
64.             m_RevealPuzzle
    
65.         End If
    
66.     End If
    
67. 
    
68.     Application.ScreenUpdating = True
    
69.     Application.StatusBar = False
    
70.    
    
71. End Sub
    
72. Sub sudoku_SolvePuzzle()
    
73. '
    
74. ' solve user entered grid
    
75. '
    
76.     Application.ScreenUpdating = False
    
77.     Application.StatusBar = SUDOKU_MSG_SOLVEPUZZLE
    
78.    
    
79.     m_SolvePuzzle
    
80.    
    
81.     Application.ScreenUpdating = True
    
82.     Application.StatusBar = False
    
83.    
    
84. End Sub

复制代码

bajifeng

第12部分：

1. Private Sub m_SolvePuzzle()
   
2. '
   
3. ' Attempt 3 times to solve puzzle before prompting for more attempts
   
4. '
   
5.     Dim intAttempts As Integer
   
6.     Dim rngTemp As Range
   
7.     Dim rngStorage As Range
   
8.     Dim rngDisplay As Range
   
9.     Dim lngRow As Long
   
10.     Dim intCol As Integer
    
11.     Dim intCell As Integer
    
12.    
    
13.     m_ClearStorage          ' store puzzle so we can do multiple attempts
    
14.     m_ProtectPuzzle False
    
15.    
    
16.     Set rngStorage = m_AssignStorage()
    
17.     Set rngDisplay = m_AssignDisplay()
    
18.    
    
19.     ' store users puzzle
    
20.     For lngRow = 1 To 9
    
21.         For intCol = 1 To 9
    
22.             If rngDisplay.Cells(lngRow, intCol).Value <> "" Then
    
23.                 rngDisplay.Cells(lngRow, intCol).Font.Bold = True
    
24.                 With rngStorage.Cells(lngRow, intCol)
    
25.                     .Font.Bold = True
    
26.                     .Value = rngDisplay.Cells(lngRow, intCol).Value
    
27.                 End With
    
28.             Else
    
29.                 rngDisplay.Cells(lngRow, intCol).Font.Bold = False
    
30.                 With rngStorage.Cells(lngRow, intCol)
    
31.                     .Font.Bold = False
    
32.                     .Value = rngDisplay.Cells(lngRow, intCol).Value
    
33.                 End With
    
34.             End If
    
35.         Next
    
36.     Next
    
37.    
    
38.     ' so try solving this puzzle
    
39.     Do
    
40.         intAttempts = intAttempts + 1
    
41.         If intAttempts > 10 Then
    
42.             ' check with user thats its ok to continue trying to solve this
    
43.             If MsgBox(SUDOKU_MSG_CONTINUESOLVING, vbExclamation Or vbYesNo) = vbNo Then
    
44.                 Exit Sub
    
45.             End If
    
46.             intAttempts = 1
    
47.         End If
    
48.         
    
49.         m_ResetPuzzleArrays
    
50.         Randomize
    
51.         m_ReadPuzzle
    
52.    
    
53.         If Not m_SanityCheck() Then Exit Sub
    
54.    
    
55.     Loop While Not m_CompleteGrid()         ' complete the solution to this grid
    
56. 
    
57.     ' output numbers to storage grid
    
58.     For Each rngTemp In rngStorage
    
59.         intCell = intCell + 1
    
60.         If m_intGrid(intCell, 0) <> 0 Then
    
61.             rngTemp = m_intGrid(intCell, 0)
    
62.         End If
    
63.     Next
    
64.    
    
65.     m_RevealPuzzle
    
66.    
    
67. End Sub

复制代码

bajifeng

第13部分：

1. Private Function m_Unsolved() As Boolean
   
2. '
   
3. ' Test for cells that contain more
   
4. '
   
5.     Dim intCell As Integer
   
6.    
   
7.     For intCell = 1 To 81
   
8.         If m_intGrid(intCell, 0) = 0 Then
   
9.             m_Unsolved = True
   
10.             Exit For
    
11.         End If
    
12.     Next
    
13.    
    
14. End Function
    
15. 
    
16. Private Function m_WhichSubRow(Cell As Integer) As Integer
    
17. ' return grid row from given index
    
18.     m_WhichSubRow = ((Cell - 1) \ 9) + 1
    
19. End Function
    
20. Private Function m_WhichSubCol(Cell As Integer) As Integer
    
21. ' return grid col from given index
    
22.     Dim intIndex As Integer
    
23.    
    
24.     intIndex = Cell
    
25.     Do While intIndex > 9
    
26.         intIndex = intIndex - 9
    
27.     Loop
    
28.     m_WhichSubCol = intIndex
    
29.    
    
30. End Function
    
31. 
    
32. Private Function m_GetCellIndex(SubGrid As Integer, Cell As Integer) As Integer
    
33. '
    
34. ' Return Offset position of cell give subcell and cell position
    
35. '
    
36.     Dim intRow As Integer
    
37.     Dim intCol As Integer
    
38.     Dim intSubRow As Integer
    
39.     Dim intSubCol As Integer
    
40.    
    
41.     intRow = (Cell + 2) \ 3
    
42.     intCol = ((Cell - 1) Mod 3) + 1
    
43.    
    
44.     intSubRow = m_GetSubGridRow(SubGrid)
    
45.     intSubCol = m_GetSubGridCol(SubGrid)
    
46.    
    
47.     m_GetCellIndex = ((intSubRow - 1) * 27) + ((intRow - 1) * 9) + ((intSubCol - 1) * 3) + intCol
    
48.    
    
49. End Function
    
50. 
    
51. Sub m_PopulateSubGrid(Index As Integer)
    
52. '
    
53. ' Randomly fill as 3x3 grid with
    
54. '
    
55.     Dim intIndex As Integer
    
56.     Dim intOrder(9) As Integer
    
57.     Dim intNumber(9) As Integer
    
58.     Dim intCell As Integer
    
59.     Dim intLoop As Integer
    
60.     Dim strValue As String
    
61.     Dim intSlot As Integer
    
62.    
    
63.     strValue = "123456789"
    
64.     For intIndex = 1 To 9
    
65.         intSlot = m_GetRandom(1, 9 - intIndex + 1)
    
66.         intOrder(intIndex) = Int(Mid(strValue, intSlot, 1))
    
67.         If intSlot > 1 Then
    
68.             strValue = Left(strValue, intSlot - 1) & Mid(strValue, intSlot + 1)
    
69.         Else
    
70.             strValue = Mid(strValue, intSlot + 1)
    
71.         End If
    
72.     Next
    
73.     strValue = "123456789"
    
74.     For intIndex = 1 To 9
    
75.         intSlot = m_GetRandom(1, 9 - intIndex + 1)
    
76.         intNumber(intIndex) = Int(Mid(strValue, intSlot, 1))
    
77.         If intSlot > 1 Then
    
78.             strValue = Left(strValue, intSlot - 1) & Mid(strValue, intSlot + 1)
    
79.         Else
    
80.             strValue = Mid(strValue, intSlot + 1)
    
81.         End If
    
82.     Next
    
83.    
    
84.     For intIndex = 1 To 9
    
85.         intCell = m_GetCellIndex(Index, intIndex)
    
86.         For intLoop = 1 To 9
    
87.             m_intGrid(intCell, intLoop) = -intLoop
    
88.         Next
    
89.         m_AssignCellValue intCell, intNumber(intIndex)
    
90.     Next
    
91.    
    
92. End Sub

复制代码

bajifeng

第14部分：

1. Private Sub m_StartingGrid()
   
2. '
   
3. ' Populate 3 sub grids on unique rows and columns
   
4. ' this will give us a good starting point as NONE on the
   
5. ' random values will be incorrect
   
6. '
   
7.     Dim intIndex As Integer
   
8.     Dim intLoop As Integer
   
9.     Dim intGrid As Integer
   
10.     Dim strSubGrids As String
    
11.    
    
12.     intGrid = m_GetRandom(1, 6)
    
13.     Select Case intGrid
    
14.     Case 1
    
15.         strSubGrids = "159"
    
16.     Case 2
    
17.         strSubGrids = "168"
    
18.     Case 3
    
19.         strSubGrids = "249"
    
20.     Case 4
    
21.         strSubGrids = "267"
    
22.     Case 5
    
23.         strSubGrids = "348"
    
24.     Case 6
    
25.         strSubGrids = "357"
    
26.     End Select
    
27.    
    
28.     For intIndex = 1 To 3
    
29.         intGrid = CInt(Mid(strSubGrids, intIndex, 1))
    
30.         m_PopulateSubGrid intGrid
    
31.     Next
    
32. 
    
33. End Sub
    
34. Private Function m_GetRandom(Low As Integer, High As Integer) As Integer
    
35. '
    
36. ' Return a random integer between and including Low and High
    
37. '
    
38.     If High - Low <= 0 Then
    
39.         m_GetRandom = Low
    
40.         Exit Function
    
41.     End If
    
42.     m_GetRandom = Int(Rnd * (High - Low + 1)) + Low
    
43. End Function

复制代码

bajifeng

第15部分：

1. Private Sub m_GetUniqueSolution()
   
2. 
   
3.     Dim rngDisplay As Range
   
4.     Dim rngStorage As Range
   
5.     Dim rngAnswer As Range
   
6.     Dim intTestCount As Integer
   
7.     Dim lngRow As Long
   
8.     Dim intCol As Integer
   
9.     Dim blnMatch As Boolean
   
10.     Dim strProblem As String
    
11.     Dim intTestPuzzle As Integer
    
12.     Dim blnOk As Boolean
    
13.     Dim blnUnique As Boolean
    
14.     Dim intTested As Integer
    
15.    
    
16.     Application.ScreenUpdating = False
    
17.    
    
18.     Set rngDisplay = m_AssignDisplay()
    
19.     Set rngAnswer = m_AssignStorage()
    
20.     Set rngStorage = ThisWorkbook.Worksheets(SUDOKU_SHEET).Range(SUDOKU_STORAGEGRID).Offset(0, 11)
    
21.    
    
22.     intTested = 25 ' number of test solution tried before puzzle is deemed to be unique
    
23.    
    
24.     Do While Not blnUnique
    
25.    
    
26.         
    
27.         blnUnique = True
    
28.         m_GetStartingGrid       ' random select starting values
    
29.         rngAnswer.Copy rngStorage
    
30.         
    
31.         For intTestCount = 1 To intTested
    
32.             m_ProtectPuzzle False
    
33.             rngDisplay.ClearContents
    
34.             For lngRow = 1 To 9
    
35.                 For intCol = 1 To 9
    
36.                     If rngStorage.Cells(lngRow, intCol).Font.Bold Then
    
37.                         rngDisplay.Cells(lngRow, intCol).Value = rngStorage.Cells(lngRow, intCol).Value
    
38.                         rngDisplay.Cells(lngRow, intCol).Font.Bold = True
    
39.                     End If
    
40.                 Next
    
41.             Next
    
42.             
    
43.             m_SolvePuzzle
    
44. 
    
45.             blnMatch = True
    
46.             strProblem = ""
    
47.             For lngRow = 1 To 9
    
48.                 For intCol = 1 To 9
    
49.                     If rngStorage.Cells(lngRow, intCol).Value <> rngDisplay.Cells(lngRow, intCol) Then
    
50.                         blnMatch = False
    
51.                         blnUnique = False
    
52.                         Exit For
    
53.                     End If
    
54.                 Next
    
55.                 If Not blnMatch Then Exit For
    
56.             Next
    
57.             If Not blnMatch Then Exit For
    
58.         Next
    
59.    
    
60.     Loop
    
61. 
    
62.     ' Sort out Display with unique solution
    
63.     m_ProtectPuzzle False
    
64.     rngDisplay.ClearContents
    
65.     For lngRow = 1 To 9
    
66.         For intCol = 1 To 9
    
67.             If rngStorage.Cells(lngRow, intCol).Font.Bold Then
    
68.                 rngDisplay.Cells(lngRow, intCol).Value = rngStorage.Cells(lngRow, intCol).Value
    
69.                 rngDisplay.Cells(lngRow, intCol).Font.Bold = True
    
70.             End If
    
71.         Next
    
72.     Next
    
73.     rngStorage.ClearContents
    
74.     Application.ScreenUpdating = True
    
75. 
    
76. End Sub
    

复制代码

lingyuncelia

谢谢，我晕啦。能否直接一点。你直接发张破解后的数独答案，大家共享下。

bajifeng

甩x附x件x：

yangyangzhifeng

http://club.excelhome.net/thread-1433335-1-1.html
去下载一个VB版的可以逻辑解此题（功能更强），VBA版也可以

yangyangzhifeng

最终解如下
812753649943682175675491283154237896369845721287169534521974368438526917796318452