VBAで数独を解く　- 初級問題編

数独、ナンプレと呼ばれるペンシルパズルをVBAで解いてみます。
といっても奥の深いパズルなので、解答ロジックを簡単に作ることはできません。
まずは初級レベルの問題が解けるものを作成してみます。

解答の方針(作成するロジック）
コード
実行
まとめ
1. このロジックだけでは中級以上には歯が立たない

解答の方針(作成するロジック）

今回は以下のロジックをVBA化します。

①あるセルに注目をし、次の手順で数値の候補を絞っていく

同じ行ですでに使われている数字は候補から外す
同じ列ですでに使われている数字は候補から外す
3×3のエリアですでに使われている数字は候補から外す

②この探索の結果、候補が一つに絞れた場合はセルに記述する。

③1行1列目から9行9列目までこれを繰り返す
　何かしら記述した場合は新たなヒントになった可能性があるので①に戻る

コード

sheet1のオブジェクト名をsudokuとしました。

標準モジュールに次のコードを記述しました。

Option Explicit

Public Sub main()
    Dim r As Integer
    Dim c As Integer
    Dim myval As Integer
    Dim cnt As Integer
    Dim flg As Boolean
    
    flg = False
    Do While flg = False
        cnt = 0
        For r = 1 To 9
            For c = 1 To 9
                cnt = cnt + 1
                If sudoku.Cells(r, c).Value = "" Then
                    myval = try(r, c)
                    
                    If myval > 0 Then
                      '一つに絞れた値を赤文字で記入する
                        sudoku.Cells(r, c).Value = myval
                        sudoku.Cells(r, c).Font.Color = 255
                        cnt = 0     '記入をしたらカウンターをリセットする
                    End If
                End If
            Next c
        Next r
        '記入せずに81セルの走査が終わった場合はこれ以上埋められないので終了フラグを立てる
        If cnt = 81 Then flg = True
    Loop
End Sub

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 Sub
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 Function

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