Sudoku Puzzle 2

Japanese

Figure 1.

As can be seen in Figure 1, left, content of B2 cell is "fi" which means this cell can accept only "6" or "9".

Figure 1, middle and right shows an intermediate state of subsequent process provided content of B2 cell is 6 or 9, respectively. Apparently, both O3 cell and Y3 cell turn out same value "e". Thus E3 cell in Figure 1, left can be fixed as "e" (numerical value is 5).

Contrast to excellent method described above, the procedure on this page is quite simple. If the content of a cell is 3-choice, the cell is corrected as 2-choice if one of the alternatives would lead to an error. i.e. three letters become two letters. It is possible to omit a lot of methods used in previous version, and despite the simplicity of VBA, you can clear even the most difficult puzzles.

例題
1
514
7485
2
8763
18
498
36
349 



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     ' 開始セル設定(注）xlEdgeLeft=7
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)
         With myrange:   '.Font.Size = 11: .Font.Color = vbBlue: .Value = w
                          .Font.Size = 1: .Font.Color = vbWhite: .Value = w
         End With
     For Each c In Rng:       If IsNumeric(c.Value) Then Call AllChDe(c)             '数値セルより文字列消去
     Next:                   Call Execute(c, ok):               If ok = True Then GoTo Fin
SearchCell:           Set cel = Nothing
   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, ok)
                 If ok = True Then Exit For
                 If WorksheetFunction.CountBlank(Rng) > 0 Then Rng = arr0: _
                    cel.Value = Replace(cel.Value, wd, ""): Call Execute(c, ok): 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, xlEdgeTop=8, xlSolid=1
For i = 1 To 8: For j = 1 To 8
  If Cells(j, i).Borders(7).LineStyle = 1 And Cells(j, i).Borders(8).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 .Color = vbWhite 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, ok)
With WorksheetFunction
myLoop: Do While .CountIf(Rng, "?") > 0                                       'アルファベット１文字の場合
            For Each c In Rng
               If c.Value Like "[a-z]" Then w = c.Value: c.Value = Asc(c.Value) - 96: Call AllChDe(c)
            Next
        Loop:    lenadv = Len(adv): Set Ex = Nothing: Mas = Rng.Rows.Count
  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) Else _
         If .CountIf(Rng.Columns(gr), Wat) = 1 Then Set Rn = Rng.Columns(gr) Else _
         If .CountIf(bGp(gr), Wat) = 1 Then Set Rn = bGp(gr)       '特定文字がグループに 1ヶ所しかない場合
     If Not Rn Is Nothing Then
             For Each c In Rn.Cells:       If InStr(c.Value, w) Then Set Ex = c: GoTo AddProcess
             Next
     End If
  Next: Next
AddProcess:   If Not Ex Is Nothing Then Ex.Value = Asc(w) - 96: adv = adv & "i": Call AllChDe(c)
   If Len(adv) > lenadv Then GoTo myLoop Else If .CountIf(Rng, ">0") = Mas ^ 2 Then ok = True   '完了準備
End With
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

このサイトで扱った項目