Excel VBA を使って数独およびスリザーリンクを解く方法を模索してきました。数独の方は早い段階で何とかなりましたが スリザーリンク完成を機に以前のを見直すと新たに多くの知見が得られたので全面的に改訂することにしました。
図1.のように a1 〜 h8 の範囲内からパズル領域が開始するようにし、問題範囲に外枠線を引いておきます。パズルのデータ以外の記載がなくパズル領域の左端および上端に数値がそれぞれ最低一つ存在する場合は枠線がなくても OK です。
本来の数独である 9×9マスのみにしました。解法の手順は以前のと同様に最初空白マスには abcdefghi の文字列が入ります。a は 1 に b は 2 に相当します。同じ列、行、ブロックには同じ数値が入らないのが数独のルールなので、セルの値が例えば4ならばそのセルを含む列、行、ブロックの 「 d 」 ( Chr(96 + 4) = "d" ) の文字を消去することができます。また 列、行、あるいはブロック内に存在する 「 g 」 の文字が唯一か所の場合は そのセルの数値を 7 ( Asc("g") - 96 = 7 ) に確定することができます。
ペンシルで空白マスに数字を書き込んでいくとエラーになることがあります。その場合この数値は候補の値から除外できるということになります。このページの解法は正にその方法なので極めて単純で早いです。しかしパズルの解き方としては面白くなく適切でないかもしれません。数独は(株)ニコリの登録商標のようで提供している問題は激辛のものでも優れていると思います。そのような意味で以前の解法はやはり捨てがたいので残すことにしました。注意したいのは、コンピューターを使い、手当たり次第に数値を埋めて解答を求める方法とは趣旨が違うということです。そのような方法では早くて簡単ですが複数の解答が求まることもありパズルの意図を逸脱しています。
図2 の例題は以前の解法では行き詰まります。結論として、以前の方法で解ける問題がやはりニコリの数独であり、解けないようなのは推奨されないパズルなのかもしれません。
図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 'アルファベット1文字の場合 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 』としても同じです。下記1行目のようにタイプして Enter を押すと通常の VBA 同様1行が実行されます。スペースを使わず、また小文字だけでタイプしてもかまいません。2行目の 『 ? b = "", c, d 』 は 「 b = "" は正しいか? 」、「 c の値は? 」、「 d の値は? 」の意味です。このように、出力を要求する式などが複数の場合、コンマ ( , )で区切ると結果が1行で出力されます。
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 ゲームという数当てのパズルがありました。懐かしいので当時のを思い出して以下に紹介します。本来は4桁ですが9桁まで可能にしました。
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