VBA で 数独

Excel VBA を使って数独およびスリザーリンクを解く方法を模索してきました。数独の方は早い段階で何とかなりましたが スリザーリンク完成を機に以前のを見直すと新たに多くの知見が得られたので全面的に改訂することにしました。

概要

図1.

図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
514
7485
2
8763
18
498
36
349

VBA


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

このサイトで扱った項目