做数独游戏的时候，画在纸上很容易弄花眼，所以我考虑用Excel辅助做一个。
界面如下：
按下初始化表格区域按钮，会在所有单元格中填充“123456789”。如下图：
当某个单元格删除得只剩一个数字时，会将同一行、同一列和同一区域的其它单元格中的相同数字删除。如下图：
实现上述效果的VBA如下：
1、初始化按钮的代码：
Sub startup_Click()
Dim row%, col%
For row = 1 To 9
For col = 1 To 9
Cells(row, col) = "'123456789"
Next
Next
End Sub
以上代码仅仅简单遍历相关单元格并填充字符串。
实现自动删除关联单元格中的数字的功能的代码放在工作表的Worksheet_Change事件中，这样，只要修改相关游戏区域中的单元格，就会自动执行检查并删除有关数字。代码如下：
Private Sub Worksheet_Change(ByVal Target As Range)
Dim row%, col%, changeRow%, changeCol%, rngRow%, rngCol%, txt$
changeRow = Target.row
changeCol = Target.Column
'记录刚修改单元格的内容
txt = Cells(changeRow, changeCol)
'如果刚修改的单元格只剩下一个数字，则执行自动消除
If Len(txt) = 1 Then
'防止修改单元格内容时工作表改变事件被循环触发
Application.EnableEvents = False
'确定同一区域单元格第一行行号
If changeRow < 4 Then
rngRow = 1
ElseIf changeRow > 6 Then
rngRow = 7
Else
rngRow = 4
End If
'确定同一区域单元格第一列列号
If changeCol < 4 Then
rngCol = 1
ElseIf changeCol > 6 Then
rngCol = 7
Else
rngCol = 4
End If
'将同一行、列及区域单元格中相关的数字删除
For row = 1 To 9
For col = 1 To 9
If row = changeRow Or col = changeCol Or (row >= rngRow And row < rngRow + 3 _
And col >= rngCol And col < rngCol + 3) Then
Cells(row, col) = Replace(Cells(row, col), txt, "")
End If
Next
Next
Cells(changeRow, changeCol) = txt
'恢复事件处理以继续响应工作表改变事件
Application.EnableEvents = True
End If
End Sub
下面再附上一个用VBA做数独的程序，不过没有优化：
Sub VBA做数独()
Dim targetRegion As String
Dim origStr, tmpStr, tStr As String
'i, j, r, c, tmpr, tmpc, tr, 用于遍历表格
'stackR为堆栈指针
Dim i, j, r, c, tmpr, tmpc, tr, tc, tmpLen, targetRow, targetCol, stackR As Integer
Dim change As Boolean
Dim startTime, endTime As Date
startTime = Now()
origStr = "1,2,3,4,5,6,7,8,9"
targetRegion = "A1:I9"
stackR = 1
Application.ScreenUpdating = False
填写:
change = False
For r = 1 To 9
For c = 1 To 9
If Len(Cells(r, c)) > 1 Then
tmpStr = Cells(r, c) '单元格内容为已去掉用过的数字后的字串
ElseIf Len(Cells(r, c)) = 1 And Cells(r, c) > 0 Then
GoTo 跳到下一单元格 '单元格数字已确定，跳到下一单元格
Else
tmpStr = origStr '单元格为空单元格，设定内容为原始字符串
End If
'将同一行中已用过的数字从原始字串中去除
For tmpc = 1 To 9
If Len(Cells(r, tmpc)) = 1 Then
If InStr(tmpStr, Cells(r, tmpc)) > 0 Then
tmpStr = Replace(tmpStr, Cells(r, tmpc), "")
change = True
End If
End If
Next
'将同一列中已用过的数字从原始字串中去除
For tmpr = 1 To 9
If Len(Cells(tmpr, c)) = 1 Then
If InStr(tmpStr, Cells(tmpr, c)) > 0 Then
tmpStr = Replace(tmpStr, Cells(tmpr, c), "")
change = True
End If
End If
Next
'将同一区域中已用过的数字从原始字串中去除
If r < 4 Then
tr = 1
ElseIf r > 6 Then
tr = 7
Else
tr = 4
End If
If c < 4 Then
tc = 1
ElseIf c > 6 Then
tc = 7
Else
tc = 4
End If
For tmpr = tr To tr + 2
For tmpc = tc To tc + 2
If Len(Cells(tmpr, tmpc)) = 1 Then
If InStr(tmpStr, Cells(tmpr, tmpc)) > 0 Then
tmpStr = Replace(tmpStr, Cells(tmpr, tmpc), "")
change = True
End If
End If
Next
Next
tStr = Replace(tmpStr, ",", "")
'某个单元格的数字全部删完，那么这种填法错误
If Len(tStr) = 0 Then
If stackR > 10 Then
'出栈
Range("A" & stackR & ":i" & stackR + 8).Select
Selection.Cut
Range("A1").Select
Paste
'调整堆栈指针
stackR = stackR - 10
GoTo 填写
Else
MsgBox "(@﹏@)~，这题无解。" '堆栈到底，没有可能情况了，无解
Exit Sub
End If
ElseIf Len(tStr) = 1 Then
Cells(r, c) = tStr
Else
Cells(r, c) = tmpStr
End If
tmpStr = origStr
tStr = ""
跳到下一单元格:
Next
Next
If change = False Then
For r = 1 To 9
For c = 1 To 9
'分析同一行的情况，判断是否出现可确定数字的单元格
For tmpc = 1 To 9
If Len(Cells(r, tmpc)) > 1 Then
tStr = tStr & Cells(r, tmpc)
End If
Next
For i = 1 To 9
If Len(tStr) - Len(Replace(tStr, i, "")) = 1 Then
For tmpc = 1 To 9
If InStr(Cells(r, tmpc), i) > 0 Then
Cells(r, tmpc) = i
GoTo 填写
End If
Next
End If
Next
tStr = ""
'分析同一列的情况，判断是否出现可确定数字的单元格
For tmpr = 1 To 9
If Len(Cells(tmpr, c)) <> 1 Then
tStr = tStr & Cells(tmpr, c)
End If
Next
For i = 1 To 9
If Len(tStr) - Len(Replace(tStr, i, "")) = 1 Then
For tmpr = 1 To 9
If InStr(Cells(tmpr, c), i) > 0 Then
Cells(tmpr, c) = i
GoTo 填写
End If
Next
End If
Next
tStr = ""
'分析同一区域的情况，判断是否出现可确定数字的单元格
If r < 4 Then
tr = 1
ElseIf r > 6 Then
tr = 7
Else
tr = 4
End If
If c < 4 Then
tc = 1
ElseIf c > 6 Then
tc = 7
Else
tc = 4
End If
For tmpr = tr To tr + 2
For tmpc = tc To tc + 2
If Len(Cells(tmpr, tmpc)) <> 1 Then
tStr = tStr & Cells(tmpr, tmpc)
End If
Next
Next
For i = 1 To 9
If Len(tStr) - Len(Replace(tStr, i, "")) = 1 Then
For tmpr = tr To tr + 2
For tmpc = tc To tc + 2
If InStr(Cells(tmpr, tmpc), i) > 0 Then
Cells(tmpr, tmpc) = i
GoTo 填写
End If
Next
Next
End If
Next
Next
Next
For r = 1 To 9
For c = 1 To 9
If Len(Cells(r, c)) > 1 Then
'找到可填数字最少的未定单元格（也就是其中字符串长度最短的），使堆栈最小
tmpLen = 17
For i = 1 To 9
For j = 1 To 9
If Len(Cells(i, j)) <> 1 And Len(Cells(i, j)) < tmpLen Then
tmpLen = Len(Cells(i, j))
targetRow = i
targetCol = j
End If
Next
Next
Range(targetRegion).Copy
p = 1
s = Replace(Cells(targetRow, targetCol), ",", "")
'将所有可能情况入栈，最后一种可能情况直接在目标区修改
While p < Len(s)
stackR = stackR + 10
Range("A" & stackR).Select
Paste
Cells(stackR + targetRow - 1, targetCol) = Mid(s, p, 1)
p = p + 1
Wend
Cells(targetRow, targetCol) = Mid(s, p, 1)
GoTo 填写
End If
Next
Next
Else
GoTo 填写
End If
Application.ScreenUpdating = True
endTime = Now()
MsgBox "~\(≧▽≦)/~，解决了!耗时：" + Application.Text(endTime - startTime, "m:s")
End Sub
