ペンシルパズルの数独をエクセルVBAで解いてみます。
結論として、初級編だけでなく中級編、上級編と書かれている問題まで解くことができるものになりました。
※すべての上級編問題が解けることを保証するものではありません
パズルを解く楽しさを敢えて捨てるような無粋なことをしていますが、「VBAで繰り返し処理をする」というロジックの参考のために紹介します。
数独のルールと基本的な解き方はこちら。（ニコリ公式チャンネルより）
数独はペンシルパズル雑誌「二コリ」から生まれたパズルです。
この記事で紹介するVBAの構造体は、VBAエキスパートのスタンダードレベルで学習できます。
エクセルVBAで数独を解く 方針
セルを順に走査し、何も記入せずに81セル連続で走査した場合は処理終了とする点は前回と同じです。
詳しくは下の記事を参照ください。
前回に追加して、ニコリ公式チャンネルで「ブロッケン（ブロック＋見）」と呼ばれる初級の解法、「レッツミー」と呼ばれる中級編の解法ベースにプログラム化してみます。
具体例として、前回の初級編では
「チェック対象セルについて、同行（同列、同エリア）に同じ値があるかどうかのチェック」
という、セル目線での値確定のみだったのに対し、今回は
「1が入り得るセル候補が、その行（列、ブロック）に1つしかないのならそのセルは1で確定」
という値目線でのセル確定ができるようになります。
各セルごとに候補値を記憶する構造体を保持しておく
候補である場合は1を立てておく、候補から消えた場合は0を立て直す。
エクセルVBAで数独を解く コード
見やすさのために分割して紹介しますが、実際には一つのモジュールに記述しています。
グローバル変数の宣言
候補値は（行アドレス、列アドレス、候補の数値）の順。
Option Explicit
Private 候補値(1 To 9, 1 To 9, 1 To 9) As Integer
Private debug_flg As Boolean
Private cnt As Integerメイン
A1:I9の9×9=81マスを走査し、何かしらセルの値が確定できればよし。確定できないまま81セルの走査が終わったらギブアップのために終了フラグを立てる。
Public Sub main()
Dim rng As range
Dim stop_flg As Boolean, unique_f As Boolean
Dim tst As Integer
Dim v As Integer
debug_flg = True
stop_flg = False
cnt = 0
Call 候補値の初期化
Call 盤面の初期値取り込み
Do While stop_flg = False
For Each rng In range("A1:I9").Cells
If セルに値が未記入(rng) Then
'候補値が唯一に絞れるなら確定処理をする
If debug_flg = True Then Debug.Print rng.Address
If 候補値が唯一(rng) Then
v = 確定した候補値(rng)
Call 候補値の確定処理(rng, v)
If debug_flg = True Then Debug.Print rng.Address & ":" & v
Else
Call ブロッ見(rng)
End If
Else
cnt = cnt + 1
End If
Next rng
'記入せずに81セルの走査が終わったなら終了、またはギブアップ
If cnt > 81 Then stop_flg = True
Loop
MsgBox "終了"
End Subブロッ見
Private Sub ブロッ見(rng As range)
'セルの候補値目線ではなくブロックで見たときに
'ある値入り得るセルが一カ所に絞れているかどうかの確認
Dim i As Integer
Dim col As VBA.Collection
Set col = New VBA.Collection
For i = 1 To 9
If 候補値(rng.row, rng.Column, i) = 1 Then
If 他のセルブロックに同じ候補値がない(rng, i) Then
Call 候補値の確定処理(rng, i)
End If
End If
Next i
End Sub他のセルブロックに同じ候補値がない
例えば、どのセルも候補が一つには絞れないけど、ある数値で見たときに、その数値が入り得るセルが１セルしかない場合、その数値が入るセルが決まる。
つまり、検証したい値が、他の同ブロックのセルで候補になっている（1が立っている）かどうかをチェックする。
Private Function 他のセルブロックに同じ候補値がない(rng As range, num As Integer) As Boolean
Dim b_r, b_c As Integer
他のセルブロックに同じ候補値がない = True
Select Case rng.row
Case Is >= 7
b_r = 7
Case Is >= 4
b_r = 4
Case Is >= 1
b_r = 1
End Select
Select Case rng.Column
Case Is >= 7
b_c = 7
Case Is >= 4
b_c = 4
Case Is >= 1
b_c = 1
End Select
Dim blc As range
For Each blc In range(Cells(b_r, b_c), Cells(b_r + 2, b_c + 2)).Cells
If 候補値(blc.row, blc.Column, num) = 1 Then
If blc.row <> rng.row Or blc.Column <> rng.Column Then
他のセルブロックに同じ候補値がない = False
Exit For
End If
End If
Next blc
End Function候補値の初期化
Private Sub 候補値の初期化()
Dim rng As range
For Each rng In range("A1:I9").Cells
Call 候補値を未確定にセット(rng, Cells(rng.row, rng.Column).Value)
Next rng
End Sub盤面の初期値取り込み
初期値として決まっている値から、行、列、ブロックの中であり得ない数値が決定できる。
Private Sub 盤面の初期値取り込み()
Dim rng As range
Dim i As Integer
Dim cell_val As Integer
For Each rng In range("A1:I9").Cells
If Cells(rng.row, rng.Column).Value > 0 Then
'値が決定しているセルはその数値で確定
Call 候補値の確定処理(rng, Cells(rng.row, rng.Column).Value)
End If
Next rng
End Subセルに値が未記入（＝処理対象）、そうでなかったら処理をスキップするための確認
Private Function セルに値が未記入(c As range) As Boolean
If Cells(c.row, c.Column).Value = "" Then セルに値が未記入 = True
End Function候補値を未確定にセットする
Private Sub 候補値を未確定にセット(c As range, i As Integer)
Dim n As Integer
For n = 1 To 9
候補値(c.row, c.Column, n) = 1
Next n
End Sub候補値が一つに決まったので他の数値の可能性はなくなった。そのフラグをクリアする
Private Sub 候補値以外をクリア(rng As range, i As Integer)
Dim n As Integer
For n = 1 To 9
If n <> i Then 候補値(rng.row, rng.Column, n) = 0
Next n
End Sub候補値が唯一かどうかを確認する
Private Function 候補値が唯一(c As range) As Boolean
候補値が唯一 = False
Dim n, verify As Integer
For n = 1 To 9
verify = verify + 候補値(c.row, c.Column, n)
Next n
If verify = 1 Then 候補値が唯一 = True
End Function確定した候補値を取り出す
Private Function 確定した候補値(rng As range) As Integer
Dim i As Integer
確定した候補値 = 0
For i = 1 To 9
If 候補値(rng.row, rng.Column, i) = 1 Then 確定した候補値 = i
Next i
End Function候補値の確定プロシージャ
Private Sub 候補値の確定(rng As range, i As Integer)
Call 候補値以外をクリア(rng, i)
Call 決定セルの同ブロックの候補削除(rng, i)
Call 決定セルの同列の候補削除(rng, i)
Call 決定セルの同行の候補削除(rng, i)
候補値(rng.row, rng.Column, i) = 1
If Cells(rng.row, rng.Column).Value = "" Then
Cells(rng.row, rng.Column).Value = i
Cells(rng.row, rng.Column).Font.color = 255
End If
End Sub決定セルの同列の候補削除
Private Sub 決定セルの同列の候補削除(rng As range, val As Integer)
Dim r As Integer
For r = 1 To 9
If r <> rng.row Then 候補値(r, rng.Column, val) = 0
Next r
End Sub決定セルの同行の候補削除
Private Sub 決定セルの同行の候補削除(rng As range, val As Integer)
Dim c As Integer
For c = 1 To 9
If c <> rng.Column Then 候補値(rng.row, c, val) = 0
Next c
End Sub決定セルの同ブロックの候補削除
Private Sub 決定セルの同ブロックの候補削除(rng As range, val As Integer)
Dim b_r, b_c As Integer
Select Case rng.row
Case Is >= 7
b_r = 7
Case Is >= 4
b_r = 4
Case Is >= 1
b_r = 1
End Select
Select Case rng.Column
Case Is >= 7
b_c = 7
Case Is >= 4
b_c = 4
Case Is >= 1
b_c = 1
End Select
Dim r, c As Integer
For r = b_r To b_r + 2
For c = b_c To b_c + 2
If (r <> rng.row Or c <> rng.Column) Then 候補値(r, c, val) = 0
Next c
Next r
End SubエクセルVBAで数独を解く 実行
問題をsheet1に記入します。
mainを実行します。
解答が赤で記入されます。
まとめ
今回のプログラムで、初級～上級レベルは大体解くことができました。
最上級編など、まだまだ太刀打ちできないものはあります。奥が深いです。
いずれ機会があれば挑戦してみたいと思います。
数独はペンシルパズル雑誌「二コリ」から生まれたパズルです。
この記事で紹介するVBAの構造体は、VBAエキスパートのスタンダードレベルで学習できます。
コメント