用Excel辅助做数独

做数独游戏的时候，画在纸上很容易弄花眼，所以我考虑用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