EXCEL VBA 宏 数独游戏解法 回溯

将数独的已知数填入活动表的A1：I9单元格，打开宏编辑器，将如下语句考入编辑区。运行宏即可

Sub 数独()

'本程序有很多不足，欢迎改进！

      Dim i As Byte, t As Byte, r As Byte, x As Byte, y As Byte, zz As Integer

      Dim ta As Byte，tc As Double

      Dim hh(1 To 9, 1 To 9, 1 To 9) As Byte    '用于保存每个单元格中可能的数，经过排序最后一维保存的数从大到小，一维、二维是单元格的位置

      Dim g(1 To 9, 1 To 9) As Byte, gg(1 To 9) As Byte   '九宫和九宫的和

      Dim ypsi(1 To 9, 1 To 9) As Byte, yskn(0 To 99999, 1 To 9, 1 To 9) As Byte  '原始数组和分叉时保存数据的数组 0是起始数,原始可能的数。

      Dim jisu(1 To 9, 1 To 9) As Byte   '计数数组，由于统计每个单元格可能数字的个数，及数组hh(y,x,i)中i保留了几位数

      Dim zsjw(1 To 9) As Byte  '中间数组

      Dim dzan(0 To 99999, 1 To 6) As Integer '记录路径，候选数，历遍标志

      MsgBox "根据游戏的难易程度有可能等待几秒到几十分钟，请耐心等待！         点击     “确认”    开始"

    Application.ScreenUpdating = False     '关闭屏幕刷新

      For y = 1 To 9

        For x = 1 To 9

           ypsi(y, x) = Cells(y, x)    '把原始数据保留到数组

        Next

      Next

      yskn(0, 1, 1) = 0

      zz = 0

      ta = 0

E1:

      For y = 1 To 9

         For x = 1 To 9

            If Cells(y, x) = 0 Then Cells(y, x) = ""   '如果单元格中有0 数组将溢出，此处做技术处理

         Next

      Next

      g(1, 1) = Cells(1, 1)                   '把单元格的数转换到“宫”里以便编程

      g(1, 2) = Cells(1, 2)

      g(1, 3) = Cells(1, 3)                   '此处可以用取整函数，EVEN(y/3)来确定单元格属于哪一宫，但会增加运算次数。

      g(1, 4) = Cells(2, 1)

      g(1, 5) = Cells(2, 2)

      g(1, 6) = Cells(2, 3)

      g(1, 7) = Cells(3, 1)

      g(1, 8) = Cells(3, 2)

      g(1, 9) = Cells(3, 3)

      g(2, 1) = Cells(1, 4)

      g(2, 2) = Cells(1, 5)

      g(2, 3) = Cells(1, 6)

      g(2, 4) = Cells(2, 4)

      g(2, 5) = Cells(2, 5)

      g(2, 6) = Cells(2, 6)

      g(2, 7) = Cells(3, 4)

      g(2, 8) = Cells(3, 5)

      g(2, 9) = Cells(3, 6)

      g(3, 1) = Cells(1, 7)

      g(3, 2) = Cells(1, 8)

      g(3, 3) = Cells(1, 9)

      g(3, 4) = Cells(2, 7)

      g(3, 5) = Cells(2, 8)

      g(3, 6) = Cells(2, 9)

      g(3, 7) = Cells(3, 7)

      g(3, 8) = Cells(3, 8)

      g(3, 9) = Cells(3, 9)

      g(4, 1) = Cells(4, 1)

      g(4, 2) = Cells(4, 2)

      g(4, 3) = Cells(4, 3)

      g(4, 4) = Cells(5, 1)

      g(4, 5) = Cells(5, 2)

      g(4, 6) = Cells(5, 3)

      g(4, 7) = Cells(6, 1)

      g(4, 8) = Cells(6, 2)

      g(4, 9) = Cells(6, 3)

      g(5, 1) = Cells(4, 4)

      g(5, 2) = Cells(4, 5)

      g(5, 3) = Cells(4, 6)

      g(5, 4) = Cells(5, 4)

      g(5, 5) = Cells(5, 5)

      g(5, 6) = Cells(5, 6)

      g(5, 7) = Cells(6, 4)

      g(5, 8) = Cells(6, 5)

      g(5, 9) = Cells(6, 6)

      g(6, 1) = Cells(4, 7)

      g(6, 2) = Cells(4, 8)

      g(6, 3) = Cells(4, 9)

      g(6, 4) = Cells(5, 7)

      g(6, 5) = Cells(5, 8)

      g(6, 6) = Cells(5, 9)

      g(6, 7) = Cells(6, 7)

      g(6, 8) = Cells(6, 8)

      g(6, 9) = Cells(6, 9)

      g(7, 1) = Cells(7, 1)

      g(7, 2) = Cells(7, 2)

      g(7, 3) = Cells(7, 3)

      g(7, 4) = Cells(8, 1)

      g(7, 5) = Cells(8, 2)

      g(7, 6) = Cells(8, 3)

      g(7, 7) = Cells(9, 1)

      g(7, 8) = Cells(9, 2)

      g(7, 9) = Cells(9, 3)

      g(8, 1) = Cells(7, 4)

      g(8, 2) = Cells(7, 5)

      g(8, 3) = Cells(7, 6)

      g(8, 4) = Cells(8, 4)

      g(8, 5) = Cells(8, 5)

      g(8, 6) = Cells(8, 6)

      g(8, 7) = Cells(9, 4)

      g(8, 8) = Cells(9, 5)

      g(8, 9) = Cells(9, 6)

      g(9, 1) = Cells(7, 7)

      g(9, 2) = Cells(7, 8)

      g(9, 3) = Cells(7, 9)

      g(9, 4) = Cells(8, 7)

      g(9, 5) = Cells(8, 8)

      g(9, 6) = Cells(8, 9)

      g(9, 7) = Cells(9, 7)

      g(9, 8) = Cells(9, 8)

      g(9, 9) = Cells(9, 9)

  For y = 1 To 9

      'gg(y) = 0

      For i = 1 To 9

        jisu(y, i) = 0   '对计数数组赋值

        'gg(y) = gg(y) + g(y, i) '对每一宫的数进行合计

        For t = 1 To 9

         hh(y, i, t) = t

        Next

      Next

   Next

'''分段3

For y = 1 To 9

 For x = 1 To 9

  If Cells(y, x) > 0 And Cells(y, x) < 10 Then  '如果宫格里的数已经确定则将该数读入列

    For i = 1 To 9

    hh(y, x, i) = 0

    Next

    Else

     For i = 1 To 9

        If Cells(y, i) <> "" Or Cells(y, i) <> 0 Then

          r = Cells(y, i)   '去掉行里有的数

          hh(y, x, r) = 0

        End If

     Next

    For t = 1 To 9

        If Cells(t, x) <> "" Or Cells(t, x) <> 0 Then

         r = Cells(t, x) '去掉列里有的数

          hh(y, x, r) = 0

        End If

    Next

           If y = 1 Or y = 2 Or y = 3 Then     ''A

                  If x = 1 Or x = 2 Or x = 3 Then

                       For t = 1 To 9      '去掉宫1里有的数

                           If g(1, t) <> 0 Then

                              r = g(1, t)

                              hh(y, x, r) = 0

                           End If

                       Next

                  Else

                      If x = 4 Or x = 5 Or x = 6 Then

                             For t = 1 To 9      '去掉宫2里有的数

                                  If g(2, t) <> 0 Then

                                     r = g(2, t)

                                     hh(y, x, r) = 0

                                  End If

                             Next

                      Else

                             For t = 1 To 9      '去掉宫3里有的数

                                  If g(3, t) <> 0 Then

                                     r = g(3, t)

                                     hh(y, x, r) = 0

                                  End If

                             Next

                      End If

                 End If

        '''''''''''''

            Else ''1

               If y = 4 Or y = 5 Or y = 6 Then

                  If x = 1 Or x = 2 Or x = 3 Then ''''3

                       For t = 1 To 9      '去掉宫4里有的数

                           If g(4, t) <> 0 Then

                              r = g(4, t)

                              hh(y, x, r) = 0

                           End If

                       Next

                  Else

                      If x = 4 Or x = 5 Or x = 6 Then

                             For t = 1 To 9      '去掉宫5里有的数

                                  If g(5, t) <> 0 Then

                                     r = g(5, t)

                                     hh(y, x, r) = 0

                                  End If

                             Next

                      Else

                             For t = 1 To 9      '去掉宫6里有的数

                                  If g(6, t) <> 0 Then

                                     r = g(6, t)

                                     hh(y, x, r) = 0

                                  End If

                             Next

                      End If

                 End If ''''3

                 Else

                   If y = 7 Or y = 8 Or y = 9 Then

                       If x = 1 Or x = 2 Or x = 3 Then ''''3

                       For t = 1 To 9      '去掉宫7里有的数

                           If g(7, t) <> 0 Then

                              r = g(7, t)

                              hh(y, x, r) = 0

                           End If

                       Next

                  Else

                      If x = 4 Or x = 5 Or x = 6 Then

                             For t = 1 To 9      '去掉宫8里有的数

                                  If g(8, t) <> 0 Then

                                     r = g(8, t)

                                     hh(y, x, r) = 0

                                  End If

                             Next

                      Else

                             For t = 1 To 9      '去掉宫9里有的数

                                  If g(9, t) <> 0 Then

                                     r = g(9, t)

                                     hh(y, x, r) = 0

                                  End If

                             Next

                      End If

                 End If

                 End If ''''3

             End If '''1

          End If  ''A

End If

      For i = 1 To 9

            If hh(y, x, i) <> 0 Then     '对单元格（数组）可能的数字进行计数

              jisu(y, x) = jisu(y, x) + 1

            End If

     Next

Next

Next

'''''''对可能的数进行从大到小的排序

  For y = 1 To 9

    For x = 1 To 9

          For i = 1 To 9

             zsjw(i) = hh(y, x, i)

          Next

           For i = 1 To 9

             hh(y, x, i) = Application.WorksheetFunction.Large(zsjw, i)  '降序排序函数 和升序 small一样

           Next

    Next

  Next

'''''''排序结束

''''''对走不通的单元格进行判断

For y = 1 To 9

      For x = 1 To 9

          If Cells(y, x) = "" And jisu(y, x) = 0 Then                         '死路的条件

             For tc = 1 To zz      '''''''用负步长此处溢出，采取技术处理，有可能是VBA的bag

                 If dzan(zz - tc, 1) = 2 Or dzan(zz - tc, 1) = 3 Then                  '判断有2个候选数和有3个候选数

                     If dzan(zz - tc, 1) = 2 Then

                      dzan(zz - tc, 1) = 1

                       For i = 1 To 9

                         For t = 1 To 9

                            Cells(i, t) = yskn(zz - tc, i, t)

                         Next

                       Next

                          Cells(dzan(zz - tc, 2), dzan(zz - tc, 3)) = dzan(zz - tc, 5)

                          GoTo E1

                      End If

                      If dzan(zz - tc, 1) = 3 Then                            ''有3个候选数选第3个再试

                      dzan(zz - tc, 1) = 2

                       For i = 1 To 9

                         For t = 1 To 9

                            Cells(i, t) = yskn(zz - tc, i, t)

                         Next

                       Next

                          Cells(dzan(zz - tc, 2), dzan(zz - tc, 3)) = dzan(zz - tc, 6)

                          GoTo E1

                      End If

                 End If

             Next tc

          End If

      Next

Next

''''''判断结束

'''''''''''注释1，jisu数组中只有一个数（0除外）时，将相应的数写入相应的单元格并从头再来

 For y = 1 To 9

        For x = 1 To 9

          If jisu(y, x) = 1 Then

             Cells(y, x) = hh(y, x, 1)

             GoTo E1 '从头再来

          End If

        Next

     Next

''''''''''''''遇见候选数为2

 For y = 1 To 9

   For x = 1 To 9

          If jisu(y, x) = 2 Then                    '2个候选数，选第一个数试

               Cells(y, x) = hh(y, x, 1)            '将第一个候选数写入单元格

                zz = zz + 1                         '路径计数

                dzan(zz, 1) = 2                     '候选数标志，也是节点标志

                dzan(zz, 2) = y                     ' 行位置

                dzan(zz, 3) = x                     ' 列位置

                dzan(zz, 4) = hh(y, x, 1)           '候选数1

                dzan(zz, 5) = hh(y, x, 2)           '候选数2

                   For i = 1 To 9

                   For r = 1 To 9

                       yskn(zz, i, r) = Cells(i, r)       '将节点处的数据保存到数组

                   Next

                Next

            GoTo E1                                '从头再来

            End If

    Next

  Next

'End If                 '遇见候选数为2的结束

''''''''''''''''''''''遇见候选数为3

For y = 1 To 9

   For x = 1 To 9

          If jisu(y, x) = 3 Then                      '3个候选数，选第一个数试

               Cells(y, x) = hh(y, x, 1)

                zz = zz + 1

              dzan(zz, 1) = 3

              dzan(zz, 2) = y

              dzan(zz, 3) = x

              dzan(zz, 4) = hh(y, x, 1)

              dzan(zz, 5) = hh(y, x, 2)

              dzan(zz, 6) = hh(y, x, 3)  '候选数3

                For i = 1 To 9

                   For r = 1 To 9

                       yskn(zz, i, r) = Cells(i, r)

                   Next

                Next

                GoTo E1                                '从头再来

            End If

    Next

  Next

 ''''''''''''''''''''''''''''''遇见候选数为3的结束

For y = 1 To 9

      For x = 1 To 9

          If Cells(y, x) = "" And jisu(y, x) = 0 Then    '死路的条件

             If dzan(zz, 1) = 2 Then

                dzan(zz, 1) = 1    '表示两个数其中一个走不通，再试另外一个

                Cells(dzan(zz, 2), dzan(zz, 3)) = dzan(zz, 5)

                GoTo E1

             End If

          End If

      Next

Next

For y = 1 To 9

      For x = 1 To 9

          If Cells(y, x) = "" And jisu(y, x) = 0 Then GoTo E3

          If jisu(y, x) = 4 Then GoTo E4

      Next

Next

 '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

 Application.ScreenUpdating = True      '打开屏幕刷新

 GoTo E5

E3: MsgBox "待解,有可能是本数独无解；也有可能本程序不能应付。"

    GoTo E6

E4: MsgBox "待解,已知数太少，本程序不能应付。"

    GoTo E6

E5:

     For y = 1 To 9

     Cells(y, 10) = Cells(y, 1) + Cells(y, 2) + Cells(y, 3) + Cells(y, 4) + Cells(y, 5) + Cells(y, 6) + Cells(y, 7) + Cells(y, 8) + Cells(y, 9) '计算行之和，用于检查

     Cells(10, y) = Cells(1, y) + Cells(2, y) + Cells(3, y) + Cells(4, y) + Cells(5, y) + Cells(6, y) + Cells(7, y) + Cells(8, y) + Cells(9, y)  '计算列之和，用于检查

     Next

     MsgBox "成功完成"

E6:

 End Sub