ペンシルパズルの数独をエクセルVBAで解いてみます。
パズルを解く楽しさを敢えて捨てるような無粋なことをしていますが、「VBAで繰り返し処理をする」というロジックの参考のために紹介します。
ルール通りにチェックする工程をプログラム化ししたところ、初級編と言われるレベルのものは解くことができました。
※すべての初級編問題が解けることを保証するものではありません。
数独のルールと基本的な解き方はこちら。（ニコリ公式チャンネルより）
数独はペンシルパズル雑誌「二コリ」から生まれたパズルです。
この記事で紹介する、VBAの繰り返し処理、functionを作る事は、VBAエキスパートのスタンダードレベルで学習できます。
エクセルVBAで数独を解く 方針
解答の方針というよりも、愚直にルール通りにチェックをしていくプログラムです。
①1行1列目から9行9列目まで走査する。
そのなかで順次②のチェックをし、値が一つに決まる場合はセルに記入する。
何も記入せずに81セル連続で走査が終わった場合は終了。
（すべて埋まったか、このロジックではこれ以上解けないのでギブアップという意味）
②注目したセルに対し、次の手順で数値の候補を絞り、確定値になったらセルに記入する。
- 同じ行ですでに使われている数字は候補から外す
- 同じ列ですでに使われている数字は候補から外す
- 3×3のエリアですでに使われている数字は候補から外す
このチェックの結果、一つの値に絞れことができれば、その値をセルに赤で記入する。
③確定値をセルに記入した場合は、これが何か他のセルのヒントになる可能性があるので
①に戻る前にセル走査カウンタをリセット。セルに記入していない場合はセル走査カウンタ継続。
エクセルVBAで数独を解く コード
見やすさのために分割して紹介しますが、実際には一つのワークcシートオブジェクトに連続して記述しています。
メイン
A1:I9を走査する。値が確定できずに連続81セルの走査が終わったら終了（またはギブアップ）のために終了フラグを立てる。
Option Explicit
Public Sub main()
Dim c As Range
Dim myval As Integer
Dim cnt As Integer
Dim flg As Boolean
flg = False
Do While flg = False
cnt = 0
For Each c In Range("A1:I9").Cells
cnt = cnt + 1
If c.Value = "" Then
myval = try(c.Row, c.Column)
If myval > 0 Then
'一つに絞れた値を赤文字で記入する
c.Value = myval
c.Font.Color = 255
cnt = 0 '記入をしたらカウンターをリセットする
End If
End If
Next c
'記入せずに81セルの走査が終わった場合はこれ以上埋められないので終了フラグを立てる
If cnt = 81 Then flg = True
Loop
MsgBox "終了"
End Sub
try
チェックしているセルに対し同列、同行、同ブロックにある数値は「ありえない値」としてフラグ0を立てる。さらにその結果で候補値が一つに絞れたかどうかをチェックする。
Private Function try(r As Integer, c As Integer) As Integer
'同じ行、列、エリアで使われている数値を消去する
Dim search_row As Integer
Dim search_col As Integer
Dim candidate As Integer
Dim numbers() As Variant
numbers = Array(0, 1, 2, 3, 4, 5, 6, 7, 8, 9)
Call check_num(r, r, 1, 9, numbers) '同じ行の中で数値チェック
Call check_num(1, 9, c, c, numbers) '同じ列の中で数値チェック
'同じエリアの中で数値チェック
Select Case r
Case 1 To 3
search_row = 1
Case 4 To 6
search_row = 4
Case 7 To 9
search_row = 7
End Select
Select Case c
Case 1 To 3
search_col = 1
Case 4 To 6
search_col = 4
Case 7 To 9
search_col = 7
End Select
Call check_num(search_row, search_row + 2, search_col, search_col + 2, numbers)
'候補が一つに絞れたならその数値がセルの値になる
candidate = check_unique(numbers)
If candidate > 0 Then
try = candidate
Else
try = 0
End If
End Functioncheck_num
行アドレス、列アドレスを指定して呼び出されることで、同行チェック、同列チェック、同ブロックチェックを行う。チェックの結果使われている数値を候補値から外すためにフラグ0を立てる。
Private Sub check_num(min_r As Integer, max_r As Integer, min_c As Integer, max_c As Integer, ByRef numbers As Variant)
Dim r As Integer
Dim c As Integer
'1,2,3,4,5,6,7,8,9の構造体を受け取って、同列、同行、同エリアにある数字を除いていく
For r = min_r To max_r
For c = min_c To max_c
Select Case Cells(r, c).Value
Case ""
Case 1
numbers(1) = 0
Case 2
numbers(2) = 0
Case 3
numbers(3) = 0
Case 4
numbers(4) = 0
Case 5
numbers(5) = 0
Case 6
numbers(6) = 0
Case 7
numbers(7) = 0
Case 8
numbers(8) = 0
Case 9
numbers(9) = 0
End Select
Next c
Next r
End Subcheck_unique
候補値がユニーク（単一）になっているかどうかのチェック
単一になっていればその数値を確定値として返す。単一になっていない場合は0を返す。
Private Function check_unique(numbers As Variant) As Integer
Dim i As Integer
Dim cnt As Integer
Dim tmp_num As Integer
'構造体の中の数値を確認し、0クリアされていない場合は候補値とする
For i = 1 To 9
If numbers(i) > 0 Then
cnt = cnt + 1
tmp_num = numbers(i)
End If
Next i
'候補値が1つであれば確定値として返す。1つでない場合は0を返す
If cnt = 1 Then
check_unique = tmp_num
Else
check_unique = 0
End If
End FunctionエクセルVBAで数独を解く 実行
まとめ
ルールそのままにチェックをして確定する値を埋めていきました。
パズルを解くことそのものをプログラムで済ませてしまうという無粋なことを敢えてやりましたが、VBAで以下のことを実現する参考になれば幸いです。
- forループで繰り返し、Do untilループで繰り返し
- 関数を作り、戻り値を受け取ることで、ある種のチェック（例：候補地が単一になったかどうか）を行う
VBAの繰り返し処理、functionを作る事は、VBAエキスパートのスタンダードレベルで学習できます。
コメント