VBA で数独補足

数独の解法　補足

図1.

難解な数独の解法については数多く提案されています。一つは、マス値が二者択一でありそのいずれの場合でも他のマスの値が確定するケースを探し出す方法です。

図1．で b2 セルが "fi" になっていて、6 か 9 しか入りません。もし 6 と仮定して進めた途中図を中央に、9 とした途中図を右に示しています。o3 セルと y3 セルに注目すると、b2 セル値が 6 でも 9 でも同じ "e" になっているのが分かります。（ e3 セルの値を "e" に確定できます。）

この問題では最初から b2 セルを 6 にしても解けますが、二択の場合いつも成功すると考えるのは誤りです。最初に根拠のない数値を埋めるとその時点で全く別のパズルになるからです。

このページでの解決方法は、三者択一のセルでどれか一つの値でエラーになる（具体的には空白マスが生じる）ケースを探して、その値を排除し二択のマスに確定するものです。この方法は高度とはとても言い難く極めて単純で、前バージョンの多くの手筋や上述の方法（結構高度な方法です）は使わず、従って VBA が簡潔であるにも関わらず相当難解なパズルもクリア出来ます。しかし、この解答方法は試行錯誤的要素が多く、そもそも次の例題のようなパズルを含め余り歓迎はされません。

例題

1
5 1 4
7 4 8 5
2
8 7 6 3
1 8
4 9 8
3 6
3 4 9


Dim Rng As Range, bGp() As Range
Sub sudoku()                                    '---[ 数独II  Ver 5.0 ]---
   Call SelStart(w):  Set c0 = Range(w)
        For i = 1 To 25:       If c0.Cells(i + 1, 1).Borders(7).LineStyle <> 1 Then Exit For
        Next:  Mas = i:        If Mas = 16 Or Mas = 25 Then Else Mas = 9
ReDim bGp(1 To Mas):        Set Rng = Range(c0, c0.Cells(Mas, Mas)):    sM = Sqr(Mas)
  Call initialize(c):  n = 0
     With Rng: .HorizontalAlignment = xlCenter: .ColumnWidth = 3.4: .RowHeight = 22.6: .Borders.Weight = 2
       For j = 1 To sM: For i = 1 To sM:       n = n + 1
           Set bGp(n) = Range(Rng.Cells(sM * (j - 1) + 1, sM * (i - 1) + 1), Rng.Cells(sM * j, sM * i))
               bGp(n).BorderAround Weight:=xlThick
       Next:    Next:     End With
    A = MsgBox(Mas & "×" & Mas & " マスです。 Start?", vbYesNo):     If A = vbNo Then End
           w = "": For i = 1 To Mas: w = w & Chr(96 + i): Next                    '"abcdefghi" の 文字列作成
 Set myrange = Rng.SpecialCells(xlCellTypeBlanks): myrange.Font.Size = 1: myrange.Value = w
     For Each c In Rng:       If IsNumeric(c.Value) Then Call AllChDe(c)             '数値セルより文字列消去
     Next:                   Call Execute(c)
SearchCell: Set cel = Nothing:  If WorksheetFunction.CountIf(Rng, ">0") = Mas ^ 2 Then ok = True: GoTo Fin
   For Each c In myrange: If Len(c.Value) = 3 Then Set cel = c
   Next:              If cel Is Nothing Then GoTo Fin
  arr0 = Rng:  For i = 1 To 3: wd = Mid(cel.Value, i, 1): Rng = arr0: cel.Value = wd: Call Execute(c)
                 If ok = True Then Exit For
                 If WorksheetFunction.CountBlank(Rng) > 0 Then Rng = arr0: _
                    cel.Value = Replace(cel.Value, wd, ""): Call Execute(c): GoTo SearchCell
  Rng = arr0:  Next
Fin:    With myrange.Cells.Font: .Color = vbBlue: .Size = 11: .Italic = True      '=================最終処理
        End With:   If ok = True Then MsgBox "Completed" Else MsgBox "Give UP": Call initialize(c): End
End Sub
Function bG(c)                                                                   'セルのブロックグループ取得
      m = Rng.Rows.Count: Set c0 = Rng.Range("a1"): sM = Sqr(m)
       bG = Int((c.Column - c0.Column) / sM) + 1 + Int((c.Row - c0.Row) / sM) * sM
End Function
Sub SelStart(w)                                                 '問題範囲検索 (注）xlEdgeLeft=7, xlSolid = 1
For i = 1 To 8: For j = 1 To 8
  If Cells(j, i).Borders(7).LineStyle = 1 Then w = Cells(j, i).Address: Exit Sub          ' 開始セル番地取得
 Next: Next
Retry:        w = InputBox("開始セルをInput  例  g12" & vbCr & " 無罫線では9×9のみ、" & _
               "中止はキャンセル", "☆開始セルが特定できません"): If w = "" Then End
         If w Like "[a-zA-Z][1-9][0-9]" Or w Like "[a-zA-Z][1-9]" Then Exit Sub Else GoTo Retry
End Sub
Sub initialize(c)
   For Each c In Rng
     With c.Font:  If IsNumeric(c) = False Or .Color = vbBlue Or .Italic = True Then c.Value = ""
           .Color = 0: .Bold = False: .Italic = False: If c.Value <> "" Then .Bold = True
   End With:   Next
End Sub
Sub Execute(c)
  Do:   Do While WorksheetFunction.CountIf(Rng, "?") > 0                     'アルファベット１文字の場合
            For Each c In Rng
               If c.Value Like "[a-z]" Then c.Value = Asc(c.Value) - 96: Call AllChDe(c)
            Next
        Loop:              Mas = Rng.Rows.Count
     With WorksheetFunction:          If ok = True Then ok = ""
   For ch = 1 To Mas:  For Gr = 1 To Mas: w = Chr(96 + ch):  Wat = "*" & w & "*": Set Rn = Nothing
      If .CountIf(Rng.Rows(Gr), Wat) = 1 Then Set Rn = Rng.Rows(Gr)
      If .CountIf(Rng.Columns(Gr), Wat) = 1 Then Set Rn = Rng.Columns(Gr)
      If WorksheetFunction.CountIf(bGp(Gr), Wat) = 1 Then Set Rn = bGp(Gr)
    If Not Rn Is Nothing Then
         For Each c In Rn.Cells
           If InStr(c.Value, w) Then Set Ex = c: Ex.Value = Asc(w) - 96: Call AllChDe(c): ok = True
         Next:      End If:   Next:   Next:    End With
  Loop While ok = True
End Sub
Sub AllChDe(c)
  Set c0 = Rng.Range("a1"): Union(Rng.Rows(c.Row - c0.Row + 1), Rng.Columns(c.Column - c0.Column + 1), _
                  bGp(bG(c))).Replace What:=Chr(c.Value + 96), Replacement:=""
End Sub

余録

このページは経過上存在するページです。数独の解法は全面的に改訂しました。

このサイトで扱った項目

<a href="./frame0.html">Contents</a>

数独の解法 補足

余録

このサイトで扱った項目

数独の解法　補足