Excel VBA を使って数独およびスリザーリンクを解く方法を模索してきました。数独の方は早い段階で何とかなりましたが スリザーリンク完成を機に以前のを見直すと新たに多くの知見が得られたので全面的に改訂することにしました。
図1．のように a1 〜 h8 の範囲内からパズル領域が開始するようにし、問題範囲に外枠線を引いておきます。パズルのデータ以外の記載がなくパズル領域の左端および上端に数値がそれぞれ最低一つ存在する場合は枠線がなくても OK です。
本来の数独である ９×９マスのみにしました。解法の手順は以前のと同様に最初空白マスには abcdefghi の文字列が入ります。a は 1 に b は 2 に相当します。同じ列、行、ブロックには同じ数値が入らないのが数独のルールなので、セルの値が例えば４ならばそのセルを含む列、行、ブロックの 「 d 」 （ Chr(96 + 4) = "d" ) の文字を消去することができます。また 列、行、あるいはブロック内に存在する 「 g 」 の文字が唯一か所の場合は そのセルの数値を ７ ( Asc("g") - 96 = 7 ) に確定することができます。
ペンシルで空白マスに数字を書き込んでいくとエラーになることがあります。その場合この数値は候補の値から除外できるということになります。このページの解法は正にその方法なので極めて単純で早いです。しかしパズルの解き方としては面白くなく適切でないかもしれません。数独は（株）ニコリの登録商標のようで提供している問題は激辛のものでも優れていると思います。そのような意味で以前の解法はやはり捨てがたいので残すことにしました。注意したいのは、コンピューターを使い、手当たり次第に数値を埋めて解答を求める方法とは趣旨が違うということです。そのような方法では早くて簡単ですが複数の解答が求まることもありパズルの意図を逸脱しています。
図2 の例題は以前の解法では行き詰まります。結論として、以前の方法で解ける問題がやはりニコリの数独であり、解けないようなのは推奨されないパズルなのかもしれません。
図２．例題
| 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, G(9) As Range
Sub sudoku() '---[ 数独(新） Ver 1.3 ]---
For Each c In Range("a1:h8"): If c.Borders(7).LineStyle = 1 Then Set G(0) = c: Exit For
Next '注 xlEdgeLeft = 7; G(0) = starting cell of Puzzle Region
If G(0) Is Nothing Then
For y = 1 To 9: If Cells(y, 1).End(xlToRight).Column < 17 Then Exit For
Next
For x = 1 To 9: If Cells(1, x).End(xlDown).Row < 17 Then Exit For
Next: Set G(0) = Cells(y, x)
End If: Set Rng = Range(G(0), G(0).Cells(9, 9)): With Rng: .ColumnWidth = 3.4
.RowHeight = 22.6: .Borders.Weight = 2: .HorizontalAlignment = xlCenter: End With
For i = 1 To 9: y = 3 * (Int((i - 1) / 3)) + 1: x = 3 * ((i - 1) Mod 3) + 1
Set G(i) = G(0).Cells(y, x).Range("a1:c3"): G(i).BorderAround Weight:=xlThick
Next
Call Initialize(Rng): n = MsgBox("Start?", vbYesNo): If n = vbNo Then End
Set myR = Rng.SpecialCells(4): myR.Font.Size = 1: myR.Value = "abcdefghi"
For Each c In Rng: If IsNumeric(c.Value) Then Call AllChDe(c) '注 xlCellTypeBlanks = 4
Next: Call Execute(Fg)
For Each c In Rng
If Len(c.Value) = 3 Then
For i = 1 To 3: w1 = Mid(c.Value, i, 1): w2 = Replace(c.Value, w1, "")
Arr0 = Rng: c.Value = w1: Call Execute(Fg): If Fg = 2 Then GoTo Fin
Rng = Arr0: If Fg = -1 Then c.Value = w2: Call Execute(Fg): Exit For
Next i: End If: Next
Fin: With myR.Cells.Font: .Color = vbBlue: .Size = 11: .Italic = True: End With
If Fg = 2 Then MsgBox "Completed" Else MsgBox "Give UP": Call Initialize(Rng)
End Sub
Function bG(c) 'セルのブロックグループ取得
bG = Int((c.Column - G(0).Column) / 3) + 1 + Int((c.Row - G(0).Row) / 3) * 3
End Function
Sub Initialize(Rng)
For Each c In Rng: With c.Font: .Color = 0: .Bold = False
If .Italic = True Or .Size < 6 Or IsNumeric(c.Value) = False Then c.Value = ""
.Size = 11: .Italic = False: If c.Value <> "" Then .Bold = True
End With: Next
End Sub
Sub Execute(Fg)
Do: With WorksheetFunction: Fg = 0
Do While .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: If .CountBlank(Rng) > 0 Then Fg = -1: Exit Sub
For ch = 1 To 9: For gr = 1 To 9: w = Chr(96 + ch): Set Rn = Nothing '1ヶ所の場合
If .CountIf(Rng.Rows(gr), "*" & w & "*") = 1 Then Set Rn = Rng.Rows(gr).Cells
If .CountIf(Rng.Columns(gr), "*" & w & "*") = 1 Then Set Rn = Rng.Columns(gr).Cells
If .CountIf(G(gr), "*" & w & "*") = 1 Then Set Rn = G(gr)
If Not Rn Is Nothing Then
For Each c In Rn
If InStr(c.Value, w) Then c.Value = Asc(w) - 96: Call AllChDe(c): Fg = 1
Next: End If: Next: Next: If .CountIf(Rng, ">0") = 81 Then Fg = 2: Exit Sub
End With
Loop While Fg = 1
End Sub
Sub AllChDe(c)
Union(G(bG(c)), Rng.Rows(c.Row - G(0).Row + 1), Rng.Columns(c.Column - _
G(0).Column + 1)).Replace What:=Chr(c.Value + 96), Replacement:=""
End Sub
ゲームや年賀状ソフトは古くからコンピュータのセールスポイントに使われてきました。ゲームではアクション物やトランプ、麻雀等があり、息抜きでのプレーには適していますが以下の事は知っておいた方が良いでしょう。
一つは、コンピュータは元々シャッフル（ 完全に混ぜること ）がとても苦手、困難あるいは不可能に近いということです。つまりランダムに並んだカードも長い目でみると規則的だということです。ごく初期の麻雀ゲームでは数多くプレイしていると次の牌が分ってしまうことがあります。一方ソリティアやシャンハイなどでは予め決まったパターンで出題しています。乱数を使って作成した問題では解けないことが多いからです。
二つ目は例えばポーカーのようにシステム（ コンピューター ）側の一方的な采配で勝敗を決定できることです。麻雀で言えば配牌後の山牌を明かす必要がなく恣意的に無駄牌を自摸らせたり和了させたりできるということです。不完全ながらもランダムに配置された牌の並びを採用しているかを見極めないと息抜きになりません。
Moo ゲームという数当てのパズルがありました。ルールが単純なので思い出して以下に紹介します。出題には乱数を使いますがここでは問題にはならないでしょう。
Sub moogame()
w = "123456789": x = "": n = 4 ' n は桁数を変更するためのオプション
For i = 1 To n
Randomize
s = Mid(w, Int(Len(w) * Rnd + 1), 1): w = Replace(w, s, ""): x = x & s
Next
Set myRange = Range("b2:d16")
With myRange: .Borders.Weight = 2: .RowHeight = 22.6: .Value = ""
End With
Range("c:d").ColumnWidth = 15
MsgBox " Moo game について" & vbCr & vbCr & _
n & "桁の数字を当てるゲームです｡" & vbCr & _
"各桁の数字は全て異なり 0 は含まれません｡" & vbCr & _
"ある数値が桁の位置ともに合致すれば ◎ が一つ表示されます。" & vbCr & _
"桁の位置が違って数値が存在する場合 〇 が一つ表示されます。" & vbCr & _
"桁数の異なる回答は独自の方法で判定されます。" & vbCr & vbCr & _
" 例 正解が 7845 の場合" & vbCr & _
" 4236 …〇 1859 … ◎〇 7425 … ◎◎〇 5748 … ◎〇〇〇"
For i = 1 To 15
myRange(i, 1) = i & "回目": w = ""
a = InputBox(n & " 桁の数字を Input "): a = StrConv(a, vbNarrow)
If a = x Or a = "" Then Exit For
If Len(a) < n Then a = a & WorksheetFunction.Rept("0", n - Len(a))
myRange(i, 2) = a
For j = 1 To n
If Mid(x, j, 1) = Mid(a, j, 1) Then w = w & "◎"
Next
For j = 1 To n
s = Mid(a, j, 1)
If InStr(x, s) And Mid(x, j, 1) <> s Then w = w & "〇"
Next
myRange(i, 3) = w
Next
If a = x Then myRange(i, 2) = x: myRange(i, 3) = "正解": _
MsgBox "Perfect!" Else MsgBox "正解は " & x & " です。"
End Sub
