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
パズルだとデータが空白か (0), 1, 2, 3 の数値かという極めて単純ですが Excel では " 空白セル " の扱いが複雑なため注意が必要です。VBA の イミディエイトウインドウ は多くの情報が得られて便利です。変数 a = "" と アクティブセルが空白の場合を比較して下記に掲載します。
一覧から分かるように 同じ "" の値でも 変数と 空白セルのとでは扱いが全く異なっています。空白セルの値が正なのか （ ? b > 0 ）、 ゼロなのか （ ? b = 0 ） や ? IsNumeric(b) 等に注目します。( ? a > 0 ) や ( ? c > 0 ) が True を返すことにも注意したいところです。 c は "Excel" の文字列です。
イミディエイト（注釈）
『 Debug.Print 2 + 3 』とタイプして Enter を押すと次の行に 5 が出力されます。簡易表記で 『 Print 2 + 3 』あるいは『 ? 2 + 3 』としても同じです。下記１行目のようにタイプして Enter を押すと通常の VBA 同様１行が実行されます。スペースを使わず、また小文字だけでタイプしてもかまいません。２行目の 『 ? b = "", c, d 』 は 「 b = "" は正しいか？ 」、「 c の値は？ 」、「 d の値は？ 」の意味です。このように、出力を要求する式などが複数の場合、コンマ （ , ）で区切ると結果が１行で出力されます。
a = "": b = ActiveCell.Value: c = "Excel": d = Range("C4").Value
? b = "", c, d
True Excel abcdefghi
? a > 0, b > 0, c > 0, d > 0
True False True True
? a = 0, b = 0, c = 0, d = 0
False True False False
? IsNumeric(a), IsNumeric(b), IsNumeric(c)
False True False
? IsNull(a), IsNull(b), IsNull(c)
False False False
? IsEmpty(a), IsEmpty(b), IsEmpty(c)
False True False
? a = Empty, b = Empty, c = Empty
True True False
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
