VBAでナンプレ（数独）を解くマクロを作ってみました。
人間がナンプレを解くときの考え方をそのままプログラムにしたものなので、人間が解けるパズルは解けるし、そうでないパズルはお手上げしてしまう「人間味あふれるマクロ」を楽しんでみてくださいませ。
動作イメージはこちらです。人間が頭を悩ませる問題でも、VBAを使えば、こんな風に一瞬で解けちゃうんですよ！
スポンサーリンク
Contents
ナンプレの解き方
このマクロでは、３つの解き方をプログラムにします。
【解法1】数字探し
セルの重複禁止範囲を調べて、そのセルに入る「数字を探す」解き方です。
【例題】A1セルに入る数字を探します。
「３×３のエリア」「行」「列」には５以外の数字がすべて存在しているため、A1セルには数字の５しか入りません。
【解法2】セル探し（3×3エリア）
【例題】A1セルを始点とする３×３エリア（赤枠）に注目します。
- 空白セルは４個あり、数字２，５，７，８のいずれかが入る
- A2セル・C2セル：同じ【行】に数字の５が存在する
- B3セル：同じ【列】に数字の５が存在する
以上より、数字の５はA1セルにしか入らないことがわかります。
【解法3】セル探し（行・列エリア）
【例題】１行（赤枠）を１単位として解読します。
- １行目には空白セルが４個あり、１，４，６，７のいずれかが入る
- D1セル・F1セル：同じエリアに数字の１が存在する
- G1セル：同じ列に数字の１が存在する
以上より、数字の１はA1セルにしか入らないことがわかります。
同じように「列」に注目します。１列（赤枠）を１単位として解読します。
VBAでナンプレを解く
解法1,2,3をループの中に挟みます。
VBAのコード
アクティブシートのA1～I9セル（9×9）のパズルを解くコードです。
下記4つのモジュールに分けて貼り付けます。
- 共通モジュール
- 解法1モジュール
- 解法2モジュール
- 解法3モジュール
ExcelシートのA1～I9セル（9×9）にパズルを用意して、共通モジュールの「VBAでナンプレを解く()」を実行すると、パズルが解けます。
共通モジュール
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 |
Option Explicit Public r As Long, c As Long '現在地の行列番号 Public r1 As Long, c1 As Long 'BlockArea始点セルの行列番号 Public num As Long '1~9の数字 Sub VBAでナンプレを解く() '全体処理 Application.ScreenUpdating = False Dim PuzzleArea As Range Set PuzzleArea = ActiveSheet.Range("A1:I9") Do '【ループ１】開始 Dim BlankCnt1 As Long 'ループ２開始前の空白セル数 BlankCnt1 = WorksheetFunction.CountBlank(PuzzleArea) For r = 1 To 9 '【ループ２】開始 For c = 1 To 9 'BlockArea始点セルの特定 r1 = SearchBlockArea(r) c1 = SearchBlockArea(c) '解法１を呼び出す If Cells(r, c).Value = "" Then Call Solution1 '解法２を呼び出す If (r = 1 Or r = 4 Or r = 7) And _ (c = 1 Or c = 4 Or c = 7) Then Call Solution2 '解法３（行）を呼び出す If c = 1 Then Call Solution3_Row '解法３（列）を呼び出す If r = 1 Then Call Solution3_Col Next c Next r Dim BlankCnt2 As Long 'ループ２終了後の空白セル数 BlankCnt2 = WorksheetFunction.CountBlank(PuzzleArea) If BlankCnt1 = BlankCnt2 Then MsgBox "お手上げ！終了します。" Exit Sub End If Loop Until WorksheetFunction.CountBlank(PuzzleArea) = 0 End Sub Function SearchBlockArea(x As Long) As Long '------------------------------------------------------------------- ' * 機能：BlockArea(3×3のエリア)の始点セルを特定する ' * 引数：現在地の【行番号(r)】または【列番号(c)】 ' * 返り値：BlockArea始点セルの行番号または左端の列番号 '------------------------------------------------------------------- Select Case x Case 1, 4, 7 SearchBlockArea = x Case 2, 5, 8 SearchBlockArea = x - 1 Case 3, 6, 9 SearchBlockArea = x - 2 End Select End Function Function isExistNum _ (ByVal y1 As Long, x1 As Long, y2 As Long, x2 As Long) As Boolean ' -------------------------------------------------------------------------- ' * 機能：［指定のセル範囲］にnumが存在するか検索する ' * 引数：始点セルの【行番号】,【列番号】と終点セルの【行番号】,【列番号】 ' * 返り値：numが見つかった場合に【True】を返す ' -------------------------------------------------------------------------- Dim result As Range Set result = Range(Cells(y1, x1), Cells(y2, x2)). _ Find(what:=num, LookAt:=xlWhole) 'numが見つかったらTrueを返す If Not result Is Nothing Then isExistNum = True End Function Sub AnswerSet(ByVal y As Long, x As Long, answer As Long) ' ------------------------------------------------------------------ ' * 機能：指定のセルに解答数字を代入する ' * 引数：【セルの行番号】,【セルの列番号】,【解答数字】 ' ------------------------------------------------------------------ With Cells(y, x) .Value = answer .Font.Bold = True '太字 .Font.ColorIndex = 3 '赤 End With End Sub |
解法1モジュール
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 |
Option Explicit Option Base 1 Sub Solution1() Dim CheckFlag(9) As Boolean For num = 1 To 9 '【ループ１】 Dim check1 As Boolean, check2 As Boolean, check3 As Boolean check1 = isExistNum(r1, c1, r1 + 2, c1 + 2) '①BlockAreaの検索 check2 = isExistNum(r, 1, r, 9) '②横方向（行）の検索 check3 = isExistNum(1, c, 9, c) '③縦方向（列）の検索 '①②③のいずれかにnumが見つかったらFlagをTrueにする If check1 = True Or check2 = True Or check3 = True Then CheckFlag(num) = True End If Next num For num = 1 To 9 '【ループ２】 If CheckFlag(num) = False Then Dim cnt As Long 'Falseの数をカウント cnt = cnt + 1 Dim answer As Long '解答候補 answer = num End If Next num If cnt = 1 Then '解答決定ならセルへ書き込み Call AnswerSet(r, c, answer) End If End Sub |
解法2モジュール
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 |
Option Explicit Option Base 1 Sub Solution2() Dim BlockArea As Range Set BlockArea = Range(Cells(r1, c1), Cells(r1 + 2, c1 + 2)) '3×3エリアが完成している場合は解法２不要のためExit If WorksheetFunction.CountBlank(BlockArea) = 0 Then Exit Sub For num = 1 To 9 'BlockArea(3×3)にnumが存在しなければチェック開始 If isExistNum(r1, c1, r1 + 2, c1 + 2) = False Then Dim cell As Range For Each cell In BlockArea '各セルに対して処理を繰り返す If cell.Value = "" Then Dim check1 As Boolean, check2 As Boolean check1 = isExistNum(cell.Row, 1, cell.Row, 9) '①行検索 check2 = isExistNum(1, cell.Column, 9, cell.Column) '②列検索 'numが【行】【列】どちらにも存在しなかったら If check1 = False And check2 = False Then Dim SetCnt As Long SetCnt = SetCnt + 1 '代入可能セルの個数 Dim y As Long, x As Long y = cell.Row '現在地の【行】番号 x = cell.Column '現在地の【列】番号 End If End If Next If SetCnt = 1 Then Call AnswerSet(y, x, num) SetCnt = 0 '次のnumに進むので、カウント変数を初期化 End If Next num End Sub |
解法3モジュール
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 |
Option Explicit Sub Solution3_Row() '解読対象の行が完成している場合は不要のためExit If WorksheetFunction.CountBlank(Range(Cells(r, 1), Cells(r, 9))) = 0 Then Exit Sub End If For num = 1 To 9 '対象の【行】にnumが存在しなければチェック開始 If isExistNum(r, 1, r, 9) = False Then Dim i As Long For i = 1 To 9 '1列目～9列目を順番にチェック If Cells(r, i).Value = "" Then Dim c2 As Long c2 = SearchBlockArea(i) Dim check1 As Boolean, check2 As Boolean check1 = isExistNum(1, i, 9, i) '列のチェック check2 = isExistNum(r1, c2, r1 + 2, c2 + 2) 'BlockAreaのチェック 'どちらにもnumが存在しなければ If check1 = False And check2 = False Then Dim SetCnt As Long, x As Long SetCnt = SetCnt + 1 '代入可能セルの個数 x = i '現在地の列番号 '行番号はrなので取得不要 End If End If Next i '解答判定とセルへの書き込み If SetCnt = 1 Then Call AnswerSet(r, x, num) SetCnt = 0 '初期化 End If Next num End Sub Sub Solution3_Col() '解読対象の列が完成している場合は不要のためExit If WorksheetFunction.CountBlank(Range(Cells(1, c), Cells(9, c))) = 0 Then Exit Sub End If For num = 1 To 9 '対象の【列】にnumが存在しなければチェック開始 If isExistNum(1, c, 9, c) = False Then Dim i As Long For i = 1 To 9 '1行目～9行目を順番にチェック If Cells(i, c).Value = "" Then Dim r2 As Long r2 = SearchBlockArea(i) Dim check1 As Boolean, check2 As Boolean check1 = isExistNum(i, 1, i, 9) '行のチェック check2 = isExistNum(r2, c1, r2 + 2, c1 + 2) 'BlockAreaのチェック 'どちらにもnumが存在しなければ If check1 = False And check2 = False Then Dim SetCnt As Long, y As Long SetCnt = SetCnt + 1 '代入可能セルの個数 y = i '現在位置の行番号 '列番号はcなので取得不要 End If End If Next i If SetCnt = 1 Then Call AnswerSet(y, c, num) SetCnt = 0 '初期化 End If Next num End Sub |
以上です！
スポンサーリンク
スポンサーリンク
