用Excel辅助做数独

做数独游戏的时候，画在纸上很容易弄花眼，所以我考虑用Excel辅助做一个。
界面如下：

按下初始化表格区域按钮，会在所有单元格中填充“123456789”。如下图：

当某个单元格删除得只剩一个数字时，会将同一行、同一列和同一区域的其它单元格中的相同数字删除。如下图：

实现上述效果的VBA如下：
1、初始化按钮的代码：

Sub startup_Click()Dim row%, col%For row = 1 To 9For col = 1 To 9Cells(row, col) = "'123456789"NextNext
End Sub

以上代码仅仅简单遍历相关单元格并填充字符串。
实现自动删除关联单元格中的数字的功能的代码放在工作表的Worksheet_Change事件中，这样，只要修改相关游戏区域中的单元格，就会自动执行检查并删除有关数字。代码如下：

Private Sub Worksheet_Change(ByVal Target As Range)Dim row%, col%, changeRow%, changeCol%, rngRow%, rngCol%, txt$changeRow = Target.rowchangeCol = Target.Column'记录刚修改单元格的内容txt = Cells(changeRow, changeCol)'如果刚修改的单元格只剩下一个数字，则执行自动消除If Len(txt) = 1 Then'防止修改单元格内容时工作表改变事件被循环触发Application.EnableEvents = False'确定同一区域单元格第一行行号If changeRow < 4 ThenrngRow = 1ElseIf changeRow > 6 ThenrngRow = 7ElserngRow = 4End If'确定同一区域单元格第一列列号If changeCol < 4 ThenrngCol = 1ElseIf changeCol > 6 ThenrngCol = 7ElserngCol = 4End If'将同一行、列及区域单元格中相关的数字删除For row = 1 To 9For col = 1 To 9If row = changeRow Or col = changeCol Or (row >= rngRow And row < rngRow + 3 _And col >= rngCol And col < rngCol + 3) ThenCells(row, col) = Replace(Cells(row, col), txt, "")End IfNextNextCells(changeRow, changeCol) = txt'恢复事件处理以继续响应工作表改变事件Application.EnableEvents = TrueEnd If
End Sub

下面再附上一个用VBA做数独的程序，不过没有优化：

Sub VBA做数独()Dim targetRegion As StringDim 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 IntegerDim change As BooleanDim startTime, endTime As DatestartTime = Now()origStr = "1,2,3,4,5,6,7,8,9"targetRegion = "A1:I9"stackR = 1Application.ScreenUpdating = False   填写:change = FalseFor r = 1 To 9For c = 1 To 9If Len(Cells(r, c)) > 1 ThentmpStr = Cells(r, c) '单元格内容为已去掉用过的数字后的字串ElseIf Len(Cells(r, c)) = 1 And Cells(r, c) > 0 ThenGoTo 跳到下一单元格  '单元格数字已确定，跳到下一单元格ElsetmpStr = origStr '单元格为空单元格，设定内容为原始字符串End If '将同一行中已用过的数字从原始字串中去除For tmpc = 1 To 9If Len(Cells(r, tmpc)) = 1 ThenIf InStr(tmpStr, Cells(r, tmpc)) > 0 ThentmpStr = Replace(tmpStr, Cells(r, tmpc), "")change = TrueEnd IfEnd IfNext'将同一列中已用过的数字从原始字串中去除For tmpr = 1 To 9If Len(Cells(tmpr, c)) = 1 ThenIf InStr(tmpStr, Cells(tmpr, c)) > 0 ThentmpStr = Replace(tmpStr, Cells(tmpr, c), "")change = TrueEnd IfEnd IfNext'将同一区域中已用过的数字从原始字串中去除If r < 4 Thentr = 1ElseIf r > 6 Thentr = 7Elsetr = 4End If               If c < 4 Thentc = 1ElseIf c > 6 Thentc = 7Elsetc = 4End IfFor tmpr = tr To tr + 2For tmpc = tc To tc + 2If Len(Cells(tmpr, tmpc)) = 1 ThenIf InStr(tmpStr, Cells(tmpr, tmpc)) > 0 ThentmpStr = Replace(tmpStr, Cells(tmpr, tmpc), "")change = TrueEnd IfEnd IfNextNexttStr = Replace(tmpStr, ",", "")'某个单元格的数字全部删完，那么这种填法错误If Len(tStr) = 0 ThenIf stackR > 10 Then'出栈Range("A" & stackR & ":i" & stackR + 8).SelectSelection.CutRange("A1").SelectPaste'调整堆栈指针stackR = stackR - 10GoTo 填写ElseMsgBox "(@﹏@)~，这题无解。" '堆栈到底，没有可能情况了，无解Exit SubEnd If            ElseIf Len(tStr) = 1 ThenCells(r, c) = tStrElseCells(r, c) = tmpStrEnd IftmpStr = origStrtStr = ""           跳到下一单元格:NextNext      If change = False ThenFor r = 1 To 9For c = 1 To 9 '分析同一行的情况，判断是否出现可确定数字的单元格For tmpc = 1 To 9If Len(Cells(r, tmpc)) > 1 ThentStr = tStr & Cells(r, tmpc)End IfNext                       For i = 1 To 9If Len(tStr) - Len(Replace(tStr, i, "")) = 1 ThenFor tmpc = 1 To 9If InStr(Cells(r, tmpc), i) > 0 ThenCells(r, tmpc) = iGoTo 填写End IfNextEnd IfNexttStr = ""'分析同一列的情况，判断是否出现可确定数字的单元格For tmpr = 1 To 9If Len(Cells(tmpr, c)) <> 1 ThentStr = tStr & Cells(tmpr, c)End IfNextFor i = 1 To 9If Len(tStr) - Len(Replace(tStr, i, "")) = 1 ThenFor tmpr = 1 To 9If InStr(Cells(tmpr, c), i) > 0 ThenCells(tmpr, c) = iGoTo 填写End IfNextEnd IfNexttStr = ""'分析同一区域的情况，判断是否出现可确定数字的单元格If r < 4 Thentr = 1ElseIf r > 6 Thentr = 7Elsetr = 4End IfIf c < 4 Thentc = 1ElseIf c > 6 Thentc = 7Elsetc = 4End IfFor tmpr = tr To tr + 2For tmpc = tc To tc + 2If Len(Cells(tmpr, tmpc)) <> 1 ThentStr = tStr & Cells(tmpr, tmpc)End IfNextNextFor i = 1 To 9If Len(tStr) - Len(Replace(tStr, i, "")) = 1 ThenFor tmpr = tr To tr + 2For tmpc = tc To tc + 2If InStr(Cells(tmpr, tmpc), i) > 0 ThenCells(tmpr, tmpc) = iGoTo 填写End IfNextNextEnd IfNext NextNextFor r = 1 To 9For c = 1 To 9If Len(Cells(r, c)) > 1 Then'找到可填数字最少的未定单元格（也就是其中字符串长度最短的），使堆栈最小tmpLen = 17For i = 1 To 9For j = 1 To 9If Len(Cells(i, j)) <> 1 And Len(Cells(i, j)) < tmpLen ThentmpLen = Len(Cells(i, j))targetRow = itargetCol = jEnd IfNextNextRange(targetRegion).Copyp = 1s = Replace(Cells(targetRow, targetCol), ",", "")'将所有可能情况入栈，最后一种可能情况直接在目标区修改While p < Len(s)stackR = stackR + 10Range("A" & stackR).SelectPasteCells(stackR + targetRow - 1, targetCol) = Mid(s, p, 1)p = p + 1WendCells(targetRow, targetCol) = Mid(s, p, 1)GoTo 填写End IfNextNext  ElseGoTo 填写End IfApplication.ScreenUpdating = TrueendTime = Now()MsgBox "~\(≧▽≦)/~，解决了!耗时：" + Application.Text(endTime - startTime, "m:s")End Sub